First working version supporting node middlewares
This commit is contained in:
parent
6b22003ed4
commit
79e88a71e1
@ -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
|
||||
|
@ -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" ]
|
||||
|
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
|
||||
( 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
|
||||
|
@ -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
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