diff --git a/src/HTTPure.purs b/src/HTTPure.purs index b03e573..897fe2a 100644 --- a/src/HTTPure.purs +++ b/src/HTTPure.purs @@ -5,6 +5,8 @@ module HTTPurple , module HTTPurple.Json , module HTTPurple.Lookup , module HTTPurple.Method + , module HTTPurple.Middleware + , module HTTPurple.NodeMiddleware , module HTTPurple.Path , module HTTPurple.Routes , module HTTPurple.Query @@ -26,9 +28,23 @@ import HTTPurple.Headers (RequestHeaders, ResponseHeaders, empty, header, header import HTTPurple.Json (JsonDecoder(..), JsonEncoder(..), fromJson, jsonHeaders, toJson) import HTTPurple.Lookup (at, has, lookup, (!!), (!?), (!@)) import HTTPurple.Method (Method(..)) +import HTTPurple.Middleware (Middleware, MiddlewareM) +import HTTPurple.NodeMiddleware + ( class UsingMiddleware + , MiddlewareResult(..) + , MiddlewareResultR + , NextHandlerArg + , NextInvocation(..) + , NodeMiddleware(..) + , NodeMiddlewareStack(..) + , callNext + , callNextWithError + , dontCallNext + , usingMiddleware + ) import HTTPurple.Path (Path) import HTTPurple.Query (Query) -import HTTPurple.Request (Request, fullPath) +import HTTPurple.Request (ExtRequest, Request, RequestR, fullPath) import HTTPurple.Response (Response, ResponseM, accepted, accepted', alreadyReported, alreadyReported', badGateway, badGateway', badRequest, badRequest', conflict, conflict', continue, continue', created, created', emptyResponse, emptyResponse', expectationFailed, expectationFailed', failedDependency, failedDependency', forbidden, forbidden', found, found', gatewayTimeout, gatewayTimeout', gone, gone', hTTPVersionNotSupported, hTTPVersionNotSupported', iMUsed, iMUsed', imATeapot, imATeapot', insufficientStorage, insufficientStorage', internalServerError, internalServerError', lengthRequired, lengthRequired', locked, locked', loopDetected, loopDetected', methodNotAllowed, methodNotAllowed', misdirectedRequest, misdirectedRequest', movedPermanently, movedPermanently', multiStatus, multiStatus', multipleChoices, multipleChoices', networkAuthenticationRequired, networkAuthenticationRequired', noContent, noContent', nonAuthoritativeInformation, nonAuthoritativeInformation', notAcceptable, notAcceptable', notExtended, notExtended', notFound, notFound', notImplemented, notImplemented', notModified, notModified', ok, ok', partialContent, partialContent', payloadTooLarge, payloadTooLarge', paymentRequired, paymentRequired', permanentRedirect, permanentRedirect', preconditionFailed, preconditionFailed', preconditionRequired, preconditionRequired', processing, processing', proxyAuthenticationRequired, proxyAuthenticationRequired', rangeNotSatisfiable, rangeNotSatisfiable', requestHeaderFieldsTooLarge, requestHeaderFieldsTooLarge', requestTimeout, requestTimeout', resetContent, resetContent', response, response', seeOther, seeOther', serviceUnavailable, serviceUnavailable', switchingProtocols, switchingProtocols', temporaryRedirect, temporaryRedirect', tooManyRequests, tooManyRequests', uRITooLong, uRITooLong', unauthorized, unauthorized', unavailableForLegalReasons, unavailableForLegalReasons', unprocessableEntity, unprocessableEntity', unsupportedMediaType, unsupportedMediaType', upgradeRequired, upgradeRequired', useProxy, useProxy', variantAlsoNegotiates, variantAlsoNegotiates') import HTTPurple.Routes (type (<+>), catchAll, combineRoutes, mkRoute, orElse, (<+>)) import HTTPurple.Server (ServerM, serve) diff --git a/src/HTTPurple/Middleware.purs b/src/HTTPurple/Middleware.purs new file mode 100644 index 0000000..089d313 --- /dev/null +++ b/src/HTTPurple/Middleware.purs @@ -0,0 +1,11 @@ +module HTTPurple.Middleware + ( Middleware + , MiddlewareM + ) where + +import Effect.Aff (Aff) +import HTTPurple.Request (ExtRequest) +import HTTPurple.Response (Response) + +type MiddlewareM m route extIn extOut = (ExtRequest route extOut -> m Response) -> ExtRequest route extIn -> m Response +type Middleware route extIn extOut = MiddlewareM Aff route extIn extOut diff --git a/src/HTTPurple/NodeMiddleware.purs b/src/HTTPurple/NodeMiddleware.purs index cfe0e84..5757531 100644 --- a/src/HTTPurple/NodeMiddleware.purs +++ b/src/HTTPurple/NodeMiddleware.purs @@ -1,4 +1,16 @@ -module HTTPurple.NodeMiddleware where +module HTTPurple.NodeMiddleware + ( MiddlewareResult(..) + , MiddlewareResultR + , NextHandlerArg + , NextInvocation(..) + , NodeMiddleware(..) + , NodeMiddlewareStack(..) + , usingMiddleware + , callNext + , callNextWithError + , class UsingMiddleware + , dontCallNext + ) where import Prelude @@ -22,14 +34,14 @@ newtype NodeMiddleware extended = derive instance Newtype (NodeMiddleware extended) _ +data NextInvocation = NotCalled | ProcessingFailed Error | ProcessingSucceeded + 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 diff --git a/src/HTTPurple/Request.purs b/src/HTTPurple/Request.purs index ada216a..8ca853f 100644 --- a/src/HTTPurple/Request.purs +++ b/src/HTTPurple/Request.purs @@ -59,8 +59,11 @@ type RequestR route r = -- | the different parts of the HTTP request. type Request route = { | RequestR route () } +-- | Like `Request`, but can contain additional fields type ExtRequest route ext = { | RequestR route ext } +-- | Newtype wrapping an extended request +-- | For internal use only. Use `ExtRequest` instead. newtype ExtRequestNT :: Type -> Row Type -> Type newtype ExtRequestNT route ext = ExtRequestNT { | RequestR route ext } diff --git a/src/HTTPurple/Server.purs b/src/HTTPurple/Server.purs index 37fd2fd..f11cdf5 100644 --- a/src/HTTPurple/Server.purs +++ b/src/HTTPurple/Server.purs @@ -2,12 +2,14 @@ module HTTPurple.Server ( ClosingHandler(..) , ListenOptions , ListenOptionsR - , RoutingSettings + , BasicRoutingSettings + , ExtRoutingSettings + , MiddlewareSettingsR , RoutingSettingsR , ServerM , defaultMiddlewareErrorHandler , serve - , serveExtended + , serveNodeMiddleware ) where import Prelude @@ -27,7 +29,7 @@ import Effect.Console (error) import Effect.Exception (Error) import HTTPurple.NodeMiddleware (MiddlewareResult(..), NextInvocation(..), NodeMiddlewareStack(..)) import HTTPurple.Record.Extra as Extra -import HTTPurple.Request (ExtRequestNT, Request, RequestR, ExtRequest, fromHTTPRequest, fromHTTPRequestExt, fromHTTPRequestUnit) +import HTTPurple.Request (ExtRequest, ExtRequestNT, Request, RequestR, fromHTTPRequestExt, fromHTTPRequestUnit) import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, send) import Justifill (justifill) import Justifill.Fillable (class FillableFields) @@ -67,14 +69,7 @@ type ListenOptionsR = type ListenOptions = { | ListenOptionsR } -type RoutingSettingsR route = - ( route :: RD.RouteDuplex' route - , router :: Request route -> ResponseM - ) - -type RoutingSettings route = { | RoutingSettingsR route } - -type ExtRoutingSettingsR route output r = +type RoutingSettingsR route output r = ( route :: RD.RouteDuplex' route , router :: ExtRequest route output -> ResponseM | r @@ -82,11 +77,13 @@ type ExtRoutingSettingsR route output r = type MiddlewareSettingsR :: Row Type -> Row Type -> Row Type type MiddlewareSettingsR input output = - ( nodeMiddleware :: Maybe (NodeMiddlewareStack input output) + ( nodeMiddleware :: NodeMiddlewareStack input output ) +type BasicRoutingSettings route = { | RoutingSettingsR route () () } + type ExtRoutingSettings :: Type -> Row Type -> Row Type -> Type -type ExtRoutingSettings route input output = { | ExtRoutingSettingsR route output + MiddlewareSettingsR input output } +type ExtRoutingSettings route input output = { | RoutingSettingsR route output + MiddlewareSettingsR input output } -- | Given a router, handle unhandled exceptions it raises by -- | responding with 500 Internal Server Error. @@ -101,24 +98,7 @@ 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 --- | `Response` to the HTTP `Response`. -handleRequest :: - forall route. - { route :: RD.RouteDuplex' route - , router :: Request route -> ResponseM - , notFoundHandler :: Request Unit -> ResponseM - } -> - HTTP.Request -> - HTTP.Response -> - Effect Unit -handleRequest { route, router, notFoundHandler } request httpresponse = - void $ runAff (\_ -> pure unit) $ fromHTTPRequest route request - >>= (notFoundHandler ||| onError500 router) - >>= send httpresponse - +-- | handle requests without a routing adt. handleRequestUnit :: (Request Unit -> ResponseM) -> HTTP.Request -> @@ -129,6 +109,14 @@ handleRequestUnit router request httpresponse = >>= (onError500 router) >>= send httpresponse +-- | This function takes a record containing the +-- | * route - the routing adt +-- | * router - the request handler (a method which takes a `Request` and returns a +-- | `ResponseM`) +-- | * notFoundHandler - a handler to handle 404s +-- | as well as an HTTP `Request` and an HTTP `Response`. It runs the +-- | request, extracts the `Response` from the `ResponseM`, and sends the +-- | `Response` to the HTTP `Response`. handleExtRequest :: forall ctx ctxRL thru route. Union ctx thru ctx => @@ -162,9 +150,9 @@ handleExtRequestWithMiddleware :: HTTP.Response -> Effect Unit -handleExtRequestWithMiddleware { route, nodeMiddleware: Nothing, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ +handleExtRequestWithMiddleware { route, nodeMiddleware: Nothing, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ handleExtRequest { route, router, notFoundHandler } req resp -handleExtRequestWithMiddleware { route, nodeMiddleware:Just (NodeMiddlewareStack middleware), router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do +handleExtRequestWithMiddleware { route, nodeMiddleware: Just (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 @@ -180,62 +168,14 @@ handleExtRequestWithMiddleware { route, nodeMiddleware:Just (NodeMiddlewareStack defaultNotFoundHandler :: forall route. Request route -> ResponseM defaultNotFoundHandler = const notFound - --- | Given a `ListenOptions` and a `RoutingSettings`, creates and --- | runs a HTTPurple server. -serve :: - forall route from fromRL via missing missingList. - RowToList missing missingList => - FillableFields missingList () missing => - Union via missing (ListenOptionsR) => - RowToList from fromRL => - JustifiableFields fromRL from () via => - { | from } -> - RoutingSettings route -> - ServerM -serve inputOptions { route, router } = do - let - filledOptions :: ListenOptions - filledOptions = justifill 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 - , router - , 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 (handleRequest routingSettings) - Nothing -> HTTP.createServer (handleRequest routingSettings) - listen server options onStarted - let closingHandler = close server - registerClosingHandler filledOptions.closingHandler closingHandler - -asExtended - :: forall route ext m - . (ExtRequest route ext -> m Response) - -> ExtRequestNT route ext - -> m Response +asExtended :: + forall route ext m. + (ExtRequest route ext -> m Response) -> + ExtRequestNT route ext -> + m Response asExtended = lcmap unwrap -serveExtended :: +serveInternal :: forall route from fromRL via missing missingList input output outputRL thru. RowToList missing missingList => FillableFields missingList () missing => @@ -247,9 +187,12 @@ serveExtended :: Extra.Keys outputRL => Nub (RequestR route output) (RequestR route output) => { | from } -> - ExtRoutingSettings route input output -> + { route :: RD.RouteDuplex' route + , nodeMiddleware :: Maybe (NodeMiddlewareStack input output) + , router :: ExtRequestNT route output -> ResponseM + } -> ServerM -serveExtended inputOptions settings = do +serveInternal inputOptions settings = do let filledOptions :: ListenOptions filledOptions = justifill inputOptions @@ -265,15 +208,7 @@ serveExtended inputOptions settings = do , backlog: filledOptions.backlog } - extendedSettings = settings { router = asExtended settings.router } - - routingSettings :: - { route :: RD.RouteDuplex' route - , nodeMiddleware :: Maybe (NodeMiddlewareStack input output) - , router :: ExtRequestNT route output -> ResponseM - , notFoundHandler :: Request Unit -> ResponseM - } - routingSettings = merge extendedSettings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler } + routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler } sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile server <- case sslOptions of @@ -288,6 +223,42 @@ serveExtended inputOptions settings = do let closingHandler = close server registerClosingHandler filledOptions.closingHandler closingHandler +serve :: + forall route from fromRL via missing missingList. + RowToList missing missingList => + FillableFields missingList () missing => + Union via missing (ListenOptionsR) => + RowToList from fromRL => + JustifiableFields fromRL from () via => + { | from } -> + BasicRoutingSettings route -> + ServerM +serve inputOptions { route, router } = do + let + extendedSettings = { route, router: asExtended router, nodeMiddleware: Nothing } + + serveInternal inputOptions extendedSettings + +serveNodeMiddleware :: + 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 +serveNodeMiddleware inputOptions { route, router, nodeMiddleware } = do + let + extendedSettings = { route, router: asExtended router, nodeMiddleware: Just nodeMiddleware } + + serveInternal inputOptions extendedSettings + registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler registerClosingHandler _ closingHandler = do