thunderstrike/purescript-httpurple
thunderstrike/purescript-httpurple
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Cleanup and export everything necessary

Browse Source
This commit is contained in:
sigma-andex 2022-08-24 18:58:18 +01:00
parent 7706ae80a6
commit ef72a4476c
5 changed files with 115 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/HTTPure.purs
View File

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

11
src/HTTPurple/Middleware.purs Normal file
View File

@ -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

18
src/HTTPurple/NodeMiddleware.purs
View File

@ -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

3
src/HTTPurple/Request.purs
View File

@ -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 }

165
src/HTTPurple/Server.purs
View File

@ -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 =>
@ -164,7 +152,7 @@ handleExtRequestWithMiddleware ::
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