First working version supporting node middlewares
This commit is contained in:
parent
6b22003ed4
commit
79e88a71e1
@ -1,5 +1,6 @@
|
|||||||
let upstream =
|
let upstream =
|
||||||
https://github.com/purescript/package-sets/releases/download/psc-0.15.0-20220525/packages.dhall
|
https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220805/packages.dhall
|
||||||
sha256:5facfdf9c35801a0e6a41b08b4293f947743007a9224a2a3d7694d87a44a7f28
|
sha256:c80e241af3ba62fc42284b9bc26b4c9bd4525eebe4ab0e9198c9bbeac102f656
|
||||||
|
|
||||||
in upstream
|
in upstream
|
||||||
|
with untagged-union = ../purescript-untagged-union/spago.dhall as Location
|
||||||
|
@ -5,12 +5,17 @@
|
|||||||
, "bifunctors"
|
, "bifunctors"
|
||||||
, "console"
|
, "console"
|
||||||
, "control"
|
, "control"
|
||||||
|
, "debug"
|
||||||
, "effect"
|
, "effect"
|
||||||
, "either"
|
, "either"
|
||||||
|
, "exceptions"
|
||||||
, "foldable-traversable"
|
, "foldable-traversable"
|
||||||
, "foreign-object"
|
, "foreign-object"
|
||||||
|
, "functions"
|
||||||
, "js-uri"
|
, "js-uri"
|
||||||
, "justifill"
|
, "justifill"
|
||||||
|
, "lists"
|
||||||
|
, "literals"
|
||||||
, "maybe"
|
, "maybe"
|
||||||
, "newtype"
|
, "newtype"
|
||||||
, "node-buffer"
|
, "node-buffer"
|
||||||
@ -26,10 +31,14 @@
|
|||||||
, "record"
|
, "record"
|
||||||
, "refs"
|
, "refs"
|
||||||
, "routing-duplex"
|
, "routing-duplex"
|
||||||
|
, "safe-coerce"
|
||||||
, "strings"
|
, "strings"
|
||||||
, "transformers"
|
, "transformers"
|
||||||
, "tuples"
|
, "tuples"
|
||||||
, "type-equality"
|
, "type-equality"
|
||||||
|
, "typelevel-prelude"
|
||||||
|
, "unsafe-coerce"
|
||||||
|
, "untagged-union"
|
||||||
]
|
]
|
||||||
, packages = ./packages.dhall
|
, packages = ./packages.dhall
|
||||||
, sources = [ "src/**/*.purs" ]
|
, sources = [ "src/**/*.purs" ]
|
||||||
|
83
src/HTTPurple/NodeMiddleware.purs
Normal file
83
src/HTTPurple/NodeMiddleware.purs
Normal file
@ -0,0 +1,83 @@
|
|||||||
|
module HTTPurple.NodeMiddleware where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.Cont (ContT(..))
|
||||||
|
import Data.Generic.Rep (class Generic)
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
import Data.Newtype (class Newtype)
|
||||||
|
import Data.Show.Generic (genericShow)
|
||||||
|
import Effect (Effect)
|
||||||
|
import Effect.Exception (Error)
|
||||||
|
import Effect.Ref as Ref
|
||||||
|
import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, runEffectFn1, runEffectFn3)
|
||||||
|
import Literals.Undefined (Undefined, undefined)
|
||||||
|
import Node.HTTP as HTTP
|
||||||
|
import Prim.Row (class Union)
|
||||||
|
import Untagged.Union (type (|+|), UndefinedOr, asOneOf, uorToMaybe)
|
||||||
|
|
||||||
|
newtype NodeMiddleware :: forall k. k -> Type
|
||||||
|
newtype NodeMiddleware extended =
|
||||||
|
NodeMiddleware (EffectFn3 HTTP.Request HTTP.Response (EffectFn1 (UndefinedOr Error) Unit) (Effect Unit))
|
||||||
|
|
||||||
|
derive instance Newtype (NodeMiddleware extended) _
|
||||||
|
|
||||||
|
type MiddlewareResultR =
|
||||||
|
(request :: HTTP.Request, response :: HTTP.Response, middlewareResult :: NextInvocation)
|
||||||
|
|
||||||
|
newtype MiddlewareResult :: forall k. k -> Type
|
||||||
|
newtype MiddlewareResult input = MiddlewareResult { | MiddlewareResultR }
|
||||||
|
|
||||||
|
data NextInvocation = NotCalled | ProcessingFailed Error | ProcessingSucceeded
|
||||||
|
|
||||||
|
derive instance Generic NextInvocation _
|
||||||
|
instance Show NextInvocation where
|
||||||
|
show = genericShow
|
||||||
|
|
||||||
|
usingContinuation ::
|
||||||
|
forall input thru tmp tmp2 output.
|
||||||
|
Union input thru tmp =>
|
||||||
|
Union tmp tmp2 output =>
|
||||||
|
NodeMiddleware thru ->
|
||||||
|
MiddlewareResult input ->
|
||||||
|
(MiddlewareResult input -> Effect (MiddlewareResult output)) ->
|
||||||
|
Effect (MiddlewareResult output)
|
||||||
|
usingContinuation (NodeMiddleware middleware) reqResp@(MiddlewareResult { request, response }) nextHandler = do
|
||||||
|
middlewareResult <- callMiddleware reqResp
|
||||||
|
case middlewareResult of
|
||||||
|
res@(ProcessingSucceeded) ->
|
||||||
|
nextHandler (MiddlewareResult { request, response, middlewareResult: res })
|
||||||
|
res@(ProcessingFailed _) -> pure (MiddlewareResult { request, response, middlewareResult: res })
|
||||||
|
res@(NotCalled) -> pure (MiddlewareResult { request, response, middlewareResult: res })
|
||||||
|
where
|
||||||
|
callMiddleware :: MiddlewareResult input -> Effect (NextInvocation)
|
||||||
|
callMiddleware (MiddlewareResult { request: rIn, response: rOut }) = do
|
||||||
|
ref <- Ref.new NotCalled
|
||||||
|
let
|
||||||
|
next :: EffectFn1 (UndefinedOr Error) Unit
|
||||||
|
next = mkEffectFn1 \error -> case uorToMaybe error of
|
||||||
|
Just err -> Ref.write (ProcessingFailed err) ref
|
||||||
|
Nothing -> Ref.write (ProcessingSucceeded) ref
|
||||||
|
_ <- runEffectFn3 middleware rIn rOut next
|
||||||
|
Ref.read ref
|
||||||
|
|
||||||
|
class UsingMiddleware :: Row Type -> Row Type -> Row Type -> Constraint
|
||||||
|
class UsingMiddleware input thru output | input thru -> output where
|
||||||
|
usingMiddleware ::
|
||||||
|
NodeMiddleware thru ->
|
||||||
|
MiddlewareResult input ->
|
||||||
|
ContT (MiddlewareResult output) Effect (MiddlewareResult input)
|
||||||
|
|
||||||
|
instance (Union input thru tmp, Union tmp tmp2 output) => UsingMiddleware input thru output where
|
||||||
|
usingMiddleware nodeMiddleware reqResp = ContT $ usingContinuation nodeMiddleware reqResp
|
||||||
|
|
||||||
|
type NextHandlerArg = Undefined |+| Error
|
||||||
|
|
||||||
|
dontCallNext :: forall (m :: Type -> Type). Applicative m => m Unit
|
||||||
|
dontCallNext = pure unit
|
||||||
|
|
||||||
|
callNext :: EffectFn1 NextHandlerArg Unit -> Effect Unit
|
||||||
|
callNext next = runEffectFn1 next (asOneOf $ undefined)
|
||||||
|
|
||||||
|
callNextWithError :: EffectFn1 NextHandlerArg Unit -> Error -> Effect Unit
|
||||||
|
callNextWithError next err = runEffectFn1 next (asOneOf err)
|
8
src/HTTPurple/Record/Extra.js
Normal file
8
src/HTTPurple/Record/Extra.js
Normal file
@ -0,0 +1,8 @@
|
|||||||
|
|
||||||
|
export const pickFn = function(ks, r) {
|
||||||
|
var copy = {};
|
||||||
|
for(var i = 0; i < ks.length; i++) {
|
||||||
|
copy[ks[i]] = r[ks[i]];
|
||||||
|
}
|
||||||
|
return copy;
|
||||||
|
};
|
49
src/HTTPurple/Record/Extra.purs
Normal file
49
src/HTTPurple/Record/Extra.purs
Normal file
@ -0,0 +1,49 @@
|
|||||||
|
module HTTPurple.Record.Extra where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Array (fromFoldable)
|
||||||
|
import Data.Function.Uncurried (Fn2, runFn2)
|
||||||
|
import Data.List (List, (:))
|
||||||
|
import Data.Symbol (class IsSymbol, reflectSymbol)
|
||||||
|
import Prim.Row as Row
|
||||||
|
import Prim.RowList as RL
|
||||||
|
import Type.Proxy (Proxy(..))
|
||||||
|
|
||||||
|
class Keys (xs :: RL.RowList Type) where
|
||||||
|
keysImpl :: Proxy xs -> List String
|
||||||
|
|
||||||
|
instance Keys RL.Nil where
|
||||||
|
keysImpl _ = mempty
|
||||||
|
|
||||||
|
instance
|
||||||
|
( IsSymbol name
|
||||||
|
, Keys tail
|
||||||
|
) =>
|
||||||
|
Keys (RL.Cons name ty tail) where
|
||||||
|
keysImpl _ = first : rest
|
||||||
|
where
|
||||||
|
first = reflectSymbol (Proxy :: _ name)
|
||||||
|
rest = keysImpl (Proxy :: _ tail)
|
||||||
|
|
||||||
|
keys ::
|
||||||
|
forall g row rl.
|
||||||
|
RL.RowToList row rl =>
|
||||||
|
Keys rl =>
|
||||||
|
g row -- this will work for any type with the row as a param!
|
||||||
|
->
|
||||||
|
List String
|
||||||
|
keys _ = keysImpl (Proxy :: _ rl)
|
||||||
|
|
||||||
|
foreign import pickFn :: forall r1 r2. Fn2 (Array String) (Record r1) (Record r2)
|
||||||
|
|
||||||
|
pick ::
|
||||||
|
forall a r b l.
|
||||||
|
Row.Union b r a =>
|
||||||
|
RL.RowToList b l =>
|
||||||
|
Keys l =>
|
||||||
|
Record a ->
|
||||||
|
Record b
|
||||||
|
pick = runFn2 pickFn ks
|
||||||
|
where
|
||||||
|
ks = fromFoldable $ keys (Proxy :: _ b)
|
@ -1,16 +1,22 @@
|
|||||||
module HTTPurple.Request
|
module HTTPurple.Request
|
||||||
( Request
|
( ExtRequest(..)
|
||||||
|
, Request
|
||||||
|
, RequestR
|
||||||
, fromHTTPRequest
|
, fromHTTPRequest
|
||||||
|
, fromHTTPRequestExt
|
||||||
|
, fromHTTPRequestUnit
|
||||||
, fullPath
|
, fullPath
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Data.Bifunctor (bimap)
|
import Data.Bifunctor (rmap)
|
||||||
|
import Data.Bitraversable (bitraverse)
|
||||||
import Data.Either (Either)
|
import Data.Either (Either)
|
||||||
|
import Data.Newtype (class Newtype)
|
||||||
import Data.String (joinWith)
|
import Data.String (joinWith)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (class MonadEffect, liftEffect)
|
||||||
import Foreign.Object (isEmpty, toArrayWithKey)
|
import Foreign.Object (isEmpty, toArrayWithKey)
|
||||||
import HTTPurple.Body (RequestBody)
|
import HTTPurple.Body (RequestBody)
|
||||||
import HTTPurple.Body (read) as Body
|
import HTTPurple.Body (read) as Body
|
||||||
@ -22,17 +28,22 @@ import HTTPurple.Path (Path)
|
|||||||
import HTTPurple.Path (read) as Path
|
import HTTPurple.Path (read) as Path
|
||||||
import HTTPurple.Query (Query)
|
import HTTPurple.Query (Query)
|
||||||
import HTTPurple.Query (read) as Query
|
import HTTPurple.Query (read) as Query
|
||||||
|
import HTTPurple.Record.Extra (pick)
|
||||||
|
import HTTPurple.Record.Extra as Extra
|
||||||
import HTTPurple.Utils (encodeURIComponent)
|
import HTTPurple.Utils (encodeURIComponent)
|
||||||
import HTTPurple.Version (Version)
|
import HTTPurple.Version (Version)
|
||||||
import HTTPurple.Version (read) as Version
|
import HTTPurple.Version (read) as Version
|
||||||
import Node.HTTP (Request) as HTTP
|
import Node.HTTP (Request) as HTTP
|
||||||
import Node.HTTP (requestURL)
|
import Node.HTTP (requestURL)
|
||||||
|
import Prim.Row (class Nub, class Union)
|
||||||
|
import Prim.RowList (class RowToList)
|
||||||
|
import Record (merge)
|
||||||
import Routing.Duplex as RD
|
import Routing.Duplex as RD
|
||||||
|
import Type.Prelude (Proxy)
|
||||||
|
import Unsafe.Coerce (unsafeCoerce)
|
||||||
|
|
||||||
-- | The `Request` type is a `Record` type that includes fields for accessing
|
type RequestR route r =
|
||||||
-- | the different parts of the HTTP request.
|
( method :: Method
|
||||||
type Request route =
|
|
||||||
{ method :: Method
|
|
||||||
, path :: Path
|
, path :: Path
|
||||||
, query :: Query
|
, query :: Query
|
||||||
, route :: route
|
, route :: route
|
||||||
@ -40,36 +51,71 @@ type Request route =
|
|||||||
, body :: RequestBody
|
, body :: RequestBody
|
||||||
, httpVersion :: Version
|
, httpVersion :: Version
|
||||||
, url :: String
|
, url :: String
|
||||||
}
|
| r
|
||||||
|
)
|
||||||
|
|
||||||
|
-- | The `Request` type is a `Record` type that includes fields for accessing
|
||||||
|
-- | 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 }
|
||||||
|
|
||||||
|
derive instance Newtype (ExtRequest route ext) _
|
||||||
|
|
||||||
-- | Return the full resolved path, including query parameters. This may not
|
-- | Return the full resolved path, including query parameters. This may not
|
||||||
-- | match the requested path--for instance, if there are empty path segments in
|
-- | match the requested path--for instance, if there are empty path segments in
|
||||||
-- | the request--but it is equivalent.
|
-- | the request--but it is equivalent.
|
||||||
fullPath :: forall route. Request route -> String
|
fullPath :: forall r. { path :: Path, query :: Query | r } -> String
|
||||||
fullPath request = "/" <> path <> questionMark <> queryParams
|
fullPath { path: p, query } = "/" <> path <> questionMark <> queryParams
|
||||||
where
|
where
|
||||||
path = joinWith "/" request.path
|
path = joinWith "/" p
|
||||||
questionMark = if isEmpty request.query then "" else "?"
|
questionMark = if isEmpty query then "" else "?"
|
||||||
queryParams = joinWith "&" queryParamsArr
|
queryParams = joinWith "&" queryParamsArr
|
||||||
queryParamsArr = toArrayWithKey stringifyQueryParam request.query
|
queryParamsArr = toArrayWithKey stringifyQueryParam query
|
||||||
stringifyQueryParam key value = encodeURIComponent key <> "=" <> encodeURIComponent value
|
stringifyQueryParam key value = encodeURIComponent key <> "=" <> encodeURIComponent value
|
||||||
|
|
||||||
|
mkRequest :: forall route m. MonadEffect m => HTTP.Request -> route -> m (Request route)
|
||||||
|
mkRequest request route = do
|
||||||
|
body <- liftEffect $ Body.read request
|
||||||
|
pure
|
||||||
|
{ method: Method.read request
|
||||||
|
, path: Path.read request
|
||||||
|
, query: Query.read request
|
||||||
|
, route: route
|
||||||
|
, headers: Headers.read request
|
||||||
|
, body
|
||||||
|
, httpVersion: Version.read request
|
||||||
|
, url: requestURL request
|
||||||
|
}
|
||||||
|
|
||||||
-- | Given an HTTP `Request` object, this method will convert it to an HTTPurple
|
-- | Given an HTTP `Request` object, this method will convert it to an HTTPurple
|
||||||
-- | `Request` object.
|
-- | `Request` object.
|
||||||
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
|
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
|
||||||
fromHTTPRequest route request = do
|
fromHTTPRequest route request = do
|
||||||
body <- liftEffect $ Body.read request
|
RD.parse route (requestURL request) #
|
||||||
let
|
bitraverse (const $ mkRequest request unit) (mkRequest request)
|
||||||
mkRequest :: forall r. r -> Request r
|
|
||||||
mkRequest r =
|
|
||||||
{ method: Method.read request
|
|
||||||
, path: Path.read request
|
|
||||||
, query: Query.read request
|
|
||||||
, route: r
|
|
||||||
, headers: Headers.read request
|
|
||||||
, body
|
|
||||||
, httpVersion: Version.read request
|
|
||||||
, url: requestURL request
|
|
||||||
}
|
|
||||||
pure $ bimap (const $ mkRequest unit) mkRequest $ RD.parse route (requestURL request)
|
|
||||||
|
|
||||||
|
fromHTTPRequestUnit :: HTTP.Request -> Aff (Request Unit)
|
||||||
|
fromHTTPRequestUnit request = mkRequest request unit
|
||||||
|
|
||||||
|
fromHTTPRequestExt ::
|
||||||
|
forall ctx ctxRL thru route.
|
||||||
|
Union ctx thru ctx =>
|
||||||
|
Nub (RequestR route ctx) (RequestR route ctx) =>
|
||||||
|
RowToList ctx ctxRL =>
|
||||||
|
Extra.Keys ctxRL =>
|
||||||
|
RD.RouteDuplex' route ->
|
||||||
|
Proxy ctx ->
|
||||||
|
HTTP.Request ->
|
||||||
|
Aff (Either (Request Unit) (ExtRequest 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
|
||||||
|
|
||||||
|
request <- fromHTTPRequest route nodeRequest
|
||||||
|
pure $ rmap addExtension request
|
||||||
|
@ -5,22 +5,29 @@ module HTTPurple.Server
|
|||||||
, RoutingSettings
|
, RoutingSettings
|
||||||
, RoutingSettingsR
|
, RoutingSettingsR
|
||||||
, ServerM
|
, ServerM
|
||||||
|
, defaultMiddlewareErrorHandler
|
||||||
, serve
|
, serve
|
||||||
|
, serveWithMiddleware
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.Cont (ContT, runContT)
|
||||||
import Data.Maybe (Maybe(..), fromMaybe)
|
import Data.Maybe (Maybe(..), fromMaybe)
|
||||||
import Data.Options ((:=))
|
import Data.Options ((:=))
|
||||||
import Data.Posix.Signal (Signal(..))
|
import Data.Posix.Signal (Signal(..))
|
||||||
import Data.Profunctor.Choice ((|||))
|
import Data.Profunctor.Choice ((|||))
|
||||||
|
import Debug (spy)
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Effect.Aff (catchError, message, runAff)
|
import Effect.Aff (Aff, catchError, message, runAff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Class.Console (log)
|
import Effect.Class.Console (log)
|
||||||
import Effect.Console (error)
|
import Effect.Console (error)
|
||||||
import HTTPurple.Request (Request, fromHTTPRequest)
|
import Effect.Exception (Error)
|
||||||
import HTTPurple.Response (ResponseM, internalServerError, notFound, send)
|
import HTTPurple.NodeMiddleware (MiddlewareResult(..), NextInvocation(..))
|
||||||
|
import HTTPurple.Record.Extra as Extra
|
||||||
|
import HTTPurple.Request (ExtRequest, Request, RequestR, fromHTTPRequest, fromHTTPRequestExt, fromHTTPRequestUnit)
|
||||||
|
import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, send)
|
||||||
import Justifill (justifill)
|
import Justifill (justifill)
|
||||||
import Justifill.Fillable (class FillableFields)
|
import Justifill.Fillable (class FillableFields)
|
||||||
import Justifill.Justifiable (class JustifiableFields)
|
import Justifill.Justifiable (class JustifiableFields)
|
||||||
@ -31,9 +38,13 @@ import Node.HTTP (close, listen)
|
|||||||
import Node.HTTP.Secure (cert, certString, key, keyString)
|
import Node.HTTP.Secure (cert, certString, key, keyString)
|
||||||
import Node.HTTP.Secure (createServer) as HTTPS
|
import Node.HTTP.Secure (createServer) as HTTPS
|
||||||
import Node.Process (onSignal)
|
import Node.Process (onSignal)
|
||||||
import Prim.Row (class Union)
|
import Prim.Row (class Nub, class Union)
|
||||||
import Prim.RowList (class RowToList)
|
import Prim.RowList (class RowToList)
|
||||||
|
import Record (merge)
|
||||||
import Routing.Duplex as RD
|
import Routing.Duplex as RD
|
||||||
|
import Safe.Coerce (coerce)
|
||||||
|
import Type.Prelude (Proxy(..))
|
||||||
|
import Type.Row (type (+))
|
||||||
|
|
||||||
-- | The `ServerM` is just an `Effect` containing a callback to close the
|
-- | The `ServerM` is just an `Effect` containing a callback to close the
|
||||||
-- | server. This type is the return type of the HTTPurple serve and related
|
-- | server. This type is the return type of the HTTPurple serve and related
|
||||||
@ -62,14 +73,32 @@ type RoutingSettingsR route =
|
|||||||
|
|
||||||
type RoutingSettings route = { | RoutingSettingsR route }
|
type RoutingSettings route = { | RoutingSettingsR route }
|
||||||
|
|
||||||
|
type ExtRoutingSettingsR route output r =
|
||||||
|
( route :: RD.RouteDuplex' route
|
||||||
|
, router :: ExtRequest route output -> ResponseM
|
||||||
|
| r
|
||||||
|
)
|
||||||
|
|
||||||
|
type MiddlewareSettingsR input output =
|
||||||
|
( middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input)
|
||||||
|
, middlewareErrorHandler :: Error -> Request Unit -> Aff Response
|
||||||
|
)
|
||||||
|
|
||||||
|
type ExtRoutingSettings route input output = { | ExtRoutingSettingsR route output + MiddlewareSettingsR input output }
|
||||||
|
|
||||||
-- | Given a router, handle unhandled exceptions it raises by
|
-- | Given a router, handle unhandled exceptions it raises by
|
||||||
-- | responding with 500 Internal Server Error.
|
-- | responding with 500 Internal Server Error.
|
||||||
onError500 :: forall route. (Request route -> ResponseM) -> Request route -> ResponseM
|
onError500 :: forall request. (request -> ResponseM) -> request -> ResponseM
|
||||||
onError500 router request =
|
onError500 router request =
|
||||||
catchError (router request) \err -> do
|
catchError (router request) \err -> do
|
||||||
liftEffect $ error $ message err
|
liftEffect $ error $ message err
|
||||||
internalServerError "Internal server error"
|
internalServerError "Internal server error"
|
||||||
|
|
||||||
|
defaultMiddlewareErrorHandler :: Error -> Request Unit -> Aff Response
|
||||||
|
defaultMiddlewareErrorHandler err _ = do
|
||||||
|
liftEffect $ error $ message err
|
||||||
|
internalServerError "Internal server error"
|
||||||
|
|
||||||
-- | This function takes a method which takes a `Request` and returns a
|
-- | This function takes a method which takes a `Request` and returns a
|
||||||
-- | `ResponseM`, an HTTP `Request`, and an HTTP `Response`. It runs the
|
-- | `ResponseM`, an HTTP `Request`, and an HTTP `Response`. It runs the
|
||||||
-- | request, extracts the `Response` from the `ResponseM`, and sends the
|
-- | request, extracts the `Response` from the `ResponseM`, and sends the
|
||||||
@ -88,6 +117,62 @@ handleRequest { route, router, notFoundHandler } request httpresponse =
|
|||||||
>>= (notFoundHandler ||| onError500 router)
|
>>= (notFoundHandler ||| onError500 router)
|
||||||
>>= send httpresponse
|
>>= send httpresponse
|
||||||
|
|
||||||
|
handleRequestUnit ::
|
||||||
|
(Request Unit -> ResponseM) ->
|
||||||
|
HTTP.Request ->
|
||||||
|
HTTP.Response ->
|
||||||
|
Effect Unit
|
||||||
|
handleRequestUnit router request httpresponse =
|
||||||
|
void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request
|
||||||
|
>>= (onError500 router)
|
||||||
|
>>= send httpresponse
|
||||||
|
|
||||||
|
handleExtRequest ::
|
||||||
|
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
|
||||||
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
|
} ->
|
||||||
|
HTTP.Request ->
|
||||||
|
HTTP.Response ->
|
||||||
|
Aff Unit
|
||||||
|
handleExtRequest { route, router, notFoundHandler } req resp = do
|
||||||
|
httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req
|
||||||
|
httpurpleResp <- (notFoundHandler ||| onError500 router) httpurpleReq
|
||||||
|
send resp httpurpleResp
|
||||||
|
|
||||||
|
handleExtRequestWithMiddleware ::
|
||||||
|
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)
|
||||||
|
, middlewareErrorHandler :: Error -> Request Unit -> Aff Response
|
||||||
|
, router :: ExtRequest route output -> ResponseM
|
||||||
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
|
} ->
|
||||||
|
HTTP.Request ->
|
||||||
|
HTTP.Response ->
|
||||||
|
Effect Unit
|
||||||
|
handleExtRequestWithMiddleware { route, middleware, middlewareErrorHandler, 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
|
||||||
|
|
||||||
|
executeHandler :: MiddlewareResult output -> Aff Unit
|
||||||
|
executeHandler (MiddlewareResult { request, response, middlewareResult: ProcessingFailed error }) =
|
||||||
|
liftEffect $ handleRequestUnit (middlewareErrorHandler error) request response
|
||||||
|
executeHandler (MiddlewareResult { request, response, middlewareResult: ProcessingSucceeded }) =
|
||||||
|
handleExtRequest { route, router, notFoundHandler } request response
|
||||||
|
executeHandler (MiddlewareResult { middlewareResult: NotCalled }) =
|
||||||
|
pure unit
|
||||||
|
|
||||||
defaultNotFoundHandler :: forall route. Request route -> ResponseM
|
defaultNotFoundHandler :: forall route. Request route -> ResponseM
|
||||||
defaultNotFoundHandler = const notFound
|
defaultNotFoundHandler = const notFound
|
||||||
|
|
||||||
@ -147,12 +232,66 @@ serve inputOptions { route, router } = do
|
|||||||
Nothing -> HTTP.createServer (handleRequest routingSettings)
|
Nothing -> HTTP.createServer (handleRequest routingSettings)
|
||||||
listen server options onStarted
|
listen server options onStarted
|
||||||
let closingHandler = close server
|
let closingHandler = close server
|
||||||
case filledOptions.closingHandler of
|
registerClosingHandler filledOptions.closingHandler closingHandler
|
||||||
Just NoClosingHandler -> pure closingHandler
|
|
||||||
_ -> do
|
serveWithMiddleware ::
|
||||||
onSignal SIGINT $ closingHandler $ log "Aye, stopping service now. Goodbye!"
|
forall route from fromRL via missing missingList input output outputRL thru.
|
||||||
onSignal SIGTERM $ closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye..."
|
RowToList missing missingList =>
|
||||||
pure closingHandler
|
FillableFields missingList () missing =>
|
||||||
|
Union via missing (ListenOptionsR) =>
|
||||||
|
RowToList from fromRL =>
|
||||||
|
JustifiableFields fromRL from () via =>
|
||||||
|
Union output thru output =>
|
||||||
|
RowToList output outputRL =>
|
||||||
|
Extra.Keys outputRL =>
|
||||||
|
Nub (RequestR route output) (RequestR route output) =>
|
||||||
|
{ | from } ->
|
||||||
|
ExtRoutingSettings route input output ->
|
||||||
|
ServerM
|
||||||
|
serveWithMiddleware inputOptions settings = do
|
||||||
|
let
|
||||||
|
filledOptions :: ListenOptions
|
||||||
|
filledOptions = justifillListenOptions inputOptions
|
||||||
|
|
||||||
|
hostname = fromMaybe defaultHostname filledOptions.hostname
|
||||||
|
port = fromMaybe defaultPort filledOptions.port
|
||||||
|
onStarted = fromMaybe (defaultOnStart hostname port) filledOptions.onStarted
|
||||||
|
|
||||||
|
options :: HTTP.ListenOptions
|
||||||
|
options =
|
||||||
|
{ hostname
|
||||||
|
, port
|
||||||
|
, backlog: filledOptions.backlog
|
||||||
|
}
|
||||||
|
|
||||||
|
routingSettings ::
|
||||||
|
{ route :: RD.RouteDuplex' route
|
||||||
|
, middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input)
|
||||||
|
, middlewareErrorHandler :: Error -> Request Unit -> Aff Response
|
||||||
|
, router :: ExtRequest route output -> ResponseM
|
||||||
|
, notFoundHandler :: Request Unit -> ResponseM
|
||||||
|
}
|
||||||
|
routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
|
||||||
|
|
||||||
|
sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile
|
||||||
|
server <- case sslOptions of
|
||||||
|
Just { certFile, keyFile } ->
|
||||||
|
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)
|
||||||
|
listen server options onStarted
|
||||||
|
let closingHandler = close server
|
||||||
|
registerClosingHandler filledOptions.closingHandler closingHandler
|
||||||
|
|
||||||
|
registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM
|
||||||
|
registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler
|
||||||
|
registerClosingHandler _ closingHandler = do
|
||||||
|
onSignal SIGINT $ closingHandler $ log "Aye, stopping service now. Goodbye!"
|
||||||
|
onSignal SIGTERM $ closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye..."
|
||||||
|
pure closingHandler
|
||||||
|
|
||||||
defaultHostname :: String
|
defaultHostname :: String
|
||||||
defaultHostname = "0.0.0.0"
|
defaultHostname = "0.0.0.0"
|
||||||
|
66
src/Middleware.purs
Normal file
66
src/Middleware.purs
Normal file
@ -0,0 +1,66 @@
|
|||||||
|
module Middleware
|
||||||
|
( MiddlewareProcessing(..)
|
||||||
|
, NodeMiddleware
|
||||||
|
, using
|
||||||
|
, usingContinuation
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Control.Monad.Cont (ContT(..))
|
||||||
|
import Data.Tuple.Nested (type (/\), (/\))
|
||||||
|
import Debug (spy)
|
||||||
|
import Effect (Effect)
|
||||||
|
import Effect.Aff (launchAff_)
|
||||||
|
import Effect.Aff.Class (class MonadAff)
|
||||||
|
import Effect.Ref as Ref
|
||||||
|
import HTTPurple.Request (Request, fromHTTPRequest)
|
||||||
|
import HTTPurple.Response (Response, send)
|
||||||
|
import Node.HTTP as HTTP
|
||||||
|
import Routing.Duplex (RouteDuplex')
|
||||||
|
|
||||||
|
type NodeMiddleware = HTTP.Request -> HTTP.Response -> Effect Unit -> Effect Unit
|
||||||
|
|
||||||
|
data MiddlewareProcessing = NotStarted | ProcessingFailed | ProcessingSucceeded (HTTP.Request /\ HTTP.Response)
|
||||||
|
|
||||||
|
usingContinuation ::
|
||||||
|
NodeMiddleware ->
|
||||||
|
(HTTP.Request /\ HTTP.Response) ->
|
||||||
|
((HTTP.Request /\ HTTP.Response) -> Effect MiddlewareProcessing) ->
|
||||||
|
Effect MiddlewareProcessing
|
||||||
|
usingContinuation middleware reqResp nextHandler = do
|
||||||
|
middlewareResult <- callMiddleware reqResp
|
||||||
|
case middlewareResult of
|
||||||
|
res@(ProcessingSucceeded newReqResp) -> let _ = spy "Next called" res in nextHandler newReqResp
|
||||||
|
res -> let _ = spy "Next not called" res in pure res
|
||||||
|
where
|
||||||
|
callMiddleware :: HTTP.Request /\ HTTP.Response -> Effect (MiddlewareProcessing)
|
||||||
|
callMiddleware (req /\ resp) = do
|
||||||
|
ref <- Ref.new NotStarted
|
||||||
|
let
|
||||||
|
next :: Effect Unit
|
||||||
|
next = Ref.write (ProcessingSucceeded reqResp) ref
|
||||||
|
middleware req resp next
|
||||||
|
value <- Ref.read ref
|
||||||
|
pure value
|
||||||
|
|
||||||
|
using ::
|
||||||
|
(HTTP.Request -> HTTP.Response -> Effect Unit -> Effect Unit) ->
|
||||||
|
HTTP.Request /\ HTTP.Response ->
|
||||||
|
ContT MiddlewareProcessing Effect (HTTP.Request /\ HTTP.Response)
|
||||||
|
using nodeMiddleware reqResp = ContT $ usingContinuation nodeMiddleware reqResp
|
||||||
|
|
||||||
|
type Handler route m = Request route -> m Response
|
||||||
|
|
||||||
|
-- runHandler ::
|
||||||
|
-- forall route m.
|
||||||
|
-- MonadAff m =>
|
||||||
|
-- RouteDuplex' route ->
|
||||||
|
-- Handler route m ->
|
||||||
|
-- HTTP.Request ->
|
||||||
|
-- HTTP.Response ->
|
||||||
|
-- Effect Unit
|
||||||
|
-- runHandler rd handler req resp = launchAff_ do
|
||||||
|
-- httpurpleReq <- fromHTTPRequest rd req
|
||||||
|
-- httpurpleResp <- handler httpurpleReq
|
||||||
|
-- send resp httpurpleResp
|
Loading…
Reference in New Issue
Block a user