First working version supporting node middlewares

This commit is contained in:
sigma-andex 2022-08-08 21:08:32 +01:00
parent 6b22003ed4
commit 79e88a71e1
8 changed files with 441 additions and 40 deletions

View File

@ -1,5 +1,6 @@
let upstream =
https://github.com/purescript/package-sets/releases/download/psc-0.15.0-20220525/packages.dhall
sha256:5facfdf9c35801a0e6a41b08b4293f947743007a9224a2a3d7694d87a44a7f28
https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220805/packages.dhall
sha256:c80e241af3ba62fc42284b9bc26b4c9bd4525eebe4ab0e9198c9bbeac102f656
in upstream
with untagged-union = ../purescript-untagged-union/spago.dhall as Location

View File

@ -5,12 +5,17 @@
, "bifunctors"
, "console"
, "control"
, "debug"
, "effect"
, "either"
, "exceptions"
, "foldable-traversable"
, "foreign-object"
, "functions"
, "js-uri"
, "justifill"
, "lists"
, "literals"
, "maybe"
, "newtype"
, "node-buffer"
@ -26,10 +31,14 @@
, "record"
, "refs"
, "routing-duplex"
, "safe-coerce"
, "strings"
, "transformers"
, "tuples"
, "type-equality"
, "typelevel-prelude"
, "unsafe-coerce"
, "untagged-union"
]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs" ]

View 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)

View 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;
};

View 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)

View File

@ -1,16 +1,22 @@
module HTTPurple.Request
( Request
( ExtRequest(..)
, Request
, RequestR
, fromHTTPRequest
, fromHTTPRequestExt
, fromHTTPRequestUnit
, fullPath
) where
import Prelude
import Data.Bifunctor (bimap)
import Data.Bifunctor (rmap)
import Data.Bitraversable (bitraverse)
import Data.Either (Either)
import Data.Newtype (class Newtype)
import Data.String (joinWith)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class (class MonadEffect, liftEffect)
import Foreign.Object (isEmpty, toArrayWithKey)
import HTTPurple.Body (RequestBody)
import HTTPurple.Body (read) as Body
@ -22,17 +28,22 @@ import HTTPurple.Path (Path)
import HTTPurple.Path (read) as Path
import HTTPurple.Query (Query)
import HTTPurple.Query (read) as Query
import HTTPurple.Record.Extra (pick)
import HTTPurple.Record.Extra as Extra
import HTTPurple.Utils (encodeURIComponent)
import HTTPurple.Version (Version)
import HTTPurple.Version (read) as Version
import Node.HTTP (Request) as HTTP
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 Type.Prelude (Proxy)
import Unsafe.Coerce (unsafeCoerce)
-- | The `Request` type is a `Record` type that includes fields for accessing
-- | the different parts of the HTTP request.
type Request route =
{ method :: Method
type RequestR route r =
( method :: Method
, path :: Path
, query :: Query
, route :: route
@ -40,36 +51,71 @@ type Request route =
, body :: RequestBody
, httpVersion :: Version
, 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
-- | match the requested path--for instance, if there are empty path segments in
-- | the request--but it is equivalent.
fullPath :: forall route. Request route -> String
fullPath request = "/" <> path <> questionMark <> queryParams
fullPath :: forall r. { path :: Path, query :: Query | r } -> String
fullPath { path: p, query } = "/" <> path <> questionMark <> queryParams
where
path = joinWith "/" request.path
questionMark = if isEmpty request.query then "" else "?"
path = joinWith "/" p
questionMark = if isEmpty query then "" else "?"
queryParams = joinWith "&" queryParamsArr
queryParamsArr = toArrayWithKey stringifyQueryParam request.query
queryParamsArr = toArrayWithKey stringifyQueryParam query
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
-- | `Request` object.
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
fromHTTPRequest route request = do
body <- liftEffect $ Body.read request
let
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)
RD.parse route (requestURL request) #
bitraverse (const $ mkRequest request unit) (mkRequest 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

View File

@ -5,22 +5,29 @@ module HTTPurple.Server
, RoutingSettings
, RoutingSettingsR
, ServerM
, defaultMiddlewareErrorHandler
, serve
, serveWithMiddleware
) where
import Prelude
import Control.Monad.Cont (ContT, runContT)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Options ((:=))
import Data.Posix.Signal (Signal(..))
import Data.Profunctor.Choice ((|||))
import Debug (spy)
import Effect (Effect)
import Effect.Aff (catchError, message, runAff)
import Effect.Aff (Aff, catchError, message, runAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Effect.Console (error)
import HTTPurple.Request (Request, fromHTTPRequest)
import HTTPurple.Response (ResponseM, internalServerError, notFound, send)
import Effect.Exception (Error)
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.Fillable (class FillableFields)
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 (createServer) as HTTPS
import Node.Process (onSignal)
import Prim.Row (class Union)
import Prim.Row (class Nub, class Union)
import Prim.RowList (class RowToList)
import Record (merge)
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
-- | 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 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
-- | 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 =
catchError (router request) \err -> do
liftEffect $ error $ message err
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
-- | `ResponseM`, an HTTP `Request`, and an HTTP `Response`. It runs the
-- | request, extracts the `Response` from the `ResponseM`, and sends the
@ -88,6 +117,62 @@ handleRequest { route, router, notFoundHandler } request httpresponse =
>>= (notFoundHandler ||| onError500 router)
>>= 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 = const notFound
@ -147,12 +232,66 @@ serve inputOptions { route, router } = do
Nothing -> HTTP.createServer (handleRequest routingSettings)
listen server options onStarted
let closingHandler = close server
case filledOptions.closingHandler of
Just NoClosingHandler -> pure 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
registerClosingHandler filledOptions.closingHandler closingHandler
serveWithMiddleware ::
forall route from fromRL via missing missingList input output outputRL thru.
RowToList missing missingList =>
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 = "0.0.0.0"

66
src/Middleware.purs Normal file
View 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