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

feat: generalize ResponseM to any MonadAff

Browse Source
This commit is contained in:
orion 2023-09-30 12:32:34 -05:00
parent 077112e0ea
commit 0a3ff07fa8
Signed by: orion
GPG Key ID: 6D4165AE4C928719
5 changed files with 116 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/HTTPure.purs
View File

@ -45,7 +45,7 @@ import HTTPurple.NodeMiddleware
import HTTPurple.Path (Path)
import HTTPurple.Query (Query)
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.Response (Response, 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
( BasicRoutingSettings
@ -58,6 +58,7 @@ import HTTPurple.Server
, ServerM
, defaultMiddlewareErrorHandler
, serve
, serve'
, serveNodeMiddleware
)
import HTTPurple.Status (Status)

13
src/HTTPurple/Request.purs
View File

@ -11,13 +11,16 @@ module HTTPurple.Request
import Prelude
import Control.Monad.Error.Class (class MonadError)
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.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Foreign.Object (isEmpty, toArrayWithKey)
import HTTPurple.Body (RequestBody)
import HTTPurple.Body (read) as Body
@ -97,16 +100,18 @@ mkRequest request route = do
-- | Given an HTTP `Request` object, this method will convert it to an HTTPurple
-- | `Request` object.
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> IncomingMessage IMServer -> Aff (Either (Request Unit) (Request route))
fromHTTPRequest :: forall route m. MonadAff m => MonadError Error m => RD.RouteDuplex' route -> IncomingMessage IMServer -> m (Either (Request Unit) (Request route))
fromHTTPRequest route request = do
RD.parse route (IM.url request) #
bitraverse (const $ mkRequest request unit) (mkRequest request)
fromHTTPRequestUnit :: IncomingMessage IMServer -> Aff (Request Unit)
fromHTTPRequestUnit :: forall m. MonadEffect m => IncomingMessage IMServer -> m (Request Unit)
fromHTTPRequestUnit = flip mkRequest unit
fromHTTPRequestExt ::
forall ctx ctxRL thru route.
forall ctx ctxRL thru route m.
MonadAff m =>
MonadError Error m =>
Union ctx thru ctx =>
Nub (RequestR route ctx) (RequestR route ctx) =>
RowToList ctx ctxRL =>
@ -114,7 +119,7 @@ fromHTTPRequestExt ::
RD.RouteDuplex' route ->
Proxy ctx ->
IncomingMessage IMServer ->
Aff (Either (Request Unit) (ExtRequestNT route ctx))
m (Either (Request Unit) (ExtRequestNT route ctx))
fromHTTPRequestExt route _ nodeRequest = do
let
extension :: Record ctx

6
src/HTTPurple/Response.purs
View File

@ -1,6 +1,5 @@
module HTTPurple.Response
( Response
, ResponseM
, send
, response
, response'
@ -145,11 +144,6 @@ import HTTPurple.Status (Status)
import HTTPurple.Status (accepted, alreadyReported, badGateway, badRequest, conflict, continue, created, expectationFailed, failedDependency, forbidden, found, gatewayTimeout, gone, hTTPVersionNotSupported, iMUsed, imATeapot, insufficientStorage, internalServerError, lengthRequired, locked, loopDetected, methodNotAllowed, misdirectedRequest, movedPermanently, multiStatus, multipleChoices, networkAuthenticationRequired, noContent, nonAuthoritativeInformation, notAcceptable, notExtended, notFound, notImplemented, notModified, ok, partialContent, payloadTooLarge, paymentRequired, permanentRedirect, preconditionFailed, preconditionRequired, processing, proxyAuthenticationRequired, rangeNotSatisfiable, requestHeaderFieldsTooLarge, requestTimeout, resetContent, seeOther, serviceUnavailable, switchingProtocols, temporaryRedirect, tooManyRequests, uRITooLong, unauthorized, unavailableForLegalReasons, unprocessableEntity, unsupportedMediaType, upgradeRequired, useProxy, variantAlsoNegotiates, write) as Status
import Node.HTTP.Types (ServerResponse)
-- | The `ResponseM` type simply conveniently wraps up an HTTPurple monad that
-- | returns a response. This type is the return type of all router/route
-- | methods.
type ResponseM = Aff Response
-- | A `Response` is a status code, headers, and a body.
type Response =
{ status :: Status

12
src/HTTPurple/Routes.purs
View File

@ -13,8 +13,9 @@ import Control.Alt ((<|>))
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Profunctor.Choice ((|||))
import Effect.Aff.Class (class MonadAff)
import HTTPurple.Request (Request)
import HTTPurple.Response (ResponseM)
import HTTPurple.Response (Response)
import Record as Record
import Routing.Duplex as RD
import Routing.Duplex.Generic as RG
@ -39,11 +40,12 @@ infixr 3 combineRoutes as <+>
-- | Combine two request handlers.
orElse ::
forall left right.
(Request left -> ResponseM) ->
(Request right -> ResponseM) ->
forall left right m.
MonadAff m =>
(Request left -> m Response) ->
(Request right -> m Response) ->
Request (left <+> right) ->
ResponseM
m Response
orElse leftRouter _ request@{ route: Left l } = leftRouter $ Record.set (Proxy :: _ "route") l request
orElse _ rightRouter request@{ route: Right r } = rightRouter $ Record.set (Proxy :: _ "route") r request

164
src/HTTPurple/Server.purs
View File

@ -9,26 +9,29 @@ module HTTPurple.Server
, ServerM
, defaultMiddlewareErrorHandler
, serve
, serve'
, serveNodeMiddleware
) where
import Prelude
import Control.Monad.Cont (runContT)
import Control.Monad.Error.Class (class MonadError)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Posix.Signal (Signal(..))
import Data.Profunctor (lcmap)
import Data.Profunctor.Choice ((|||))
import Effect (Effect)
import Effect.Aff (Aff, catchError, message, runAff)
import Effect.Class (liftEffect)
import Effect.Aff (Aff, catchError, launchAff_, message)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Class.Console (log)
import Effect.Console (error)
import Effect.Exception (Error)
import HTTPurple.NodeMiddleware (MiddlewareResult(..), NextInvocation(..), NodeMiddlewareStack(..))
import HTTPurple.Request (ExtRequest, ExtRequestNT, Request, RequestR, fromHTTPRequestExt, fromHTTPRequestUnit)
import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, send)
import HTTPurple.Response (Response, internalServerError, notFound, send)
import Justifill (justifill)
import Justifill.Fillable (class FillableFields)
import Justifill.Justifiable (class JustifiableFields)
@ -58,22 +61,22 @@ type ServerM = Effect (Effect Unit -> Effect Unit)
data ClosingHandler = DefaultClosingHandler | NoClosingHandler
type ListenOptionsR =
type ListenOptionsR m =
( hostname :: Maybe String
, port :: Maybe Int
, backlog :: Maybe Int
, closingHandler :: Maybe ClosingHandler
, notFoundHandler :: Maybe (Request Unit -> ResponseM)
, onStarted :: Maybe (Effect Unit)
, notFoundHandler :: Maybe (Request Unit -> m Response)
, onStarted :: Maybe (m Unit)
, certFile :: Maybe String
, keyFile :: Maybe String
)
type ListenOptions = { | ListenOptionsR }
type ListenOptions m = { | ListenOptionsR m }
type RoutingSettingsR route output r =
type RoutingSettingsR m route output r =
( route :: RD.RouteDuplex' route
, router :: ExtRequest route output -> ResponseM
, router :: ExtRequest route output -> m Response
| r
)
@ -82,104 +85,112 @@ type MiddlewareSettingsR input output =
( nodeMiddleware :: NodeMiddlewareStack input output
)
type BasicRoutingSettings route = { | RoutingSettingsR route () () }
type BasicRoutingSettings m route = { | RoutingSettingsR m route () () }
type ExtRoutingSettings :: Type -> Row Type -> Row Type -> Type
type ExtRoutingSettings route input output = { | RoutingSettingsR route output + MiddlewareSettingsR input output }
type ExtRoutingSettings :: (Type -> Type) -> Type -> Row Type -> Row Type -> Type
type ExtRoutingSettings m route input output = { | RoutingSettingsR m route output + MiddlewareSettingsR input output }
-- | Given a router, handle unhandled exceptions it raises by
-- | responding with 500 Internal Server Error.
onError500 :: forall request. (request -> ResponseM) -> request -> ResponseM
onError500 :: forall m request. MonadError Error m => MonadAff m => (request -> m Response) -> request -> m Response
onError500 router request =
catchError (router request) \err -> do
liftEffect $ error $ message err
internalServerError "Internal server error"
defaultMiddlewareErrorHandler :: Error -> Request Unit -> Aff Response
defaultMiddlewareErrorHandler :: forall m. MonadAff m => Error -> Request Unit -> m Response
defaultMiddlewareErrorHandler err _ = do
liftEffect $ error $ message err
internalServerError "Internal server error"
-- | handle requests without a routing adt.
handleRequestUnit ::
(Request Unit -> ResponseM) ->
handleRequestUnit :: forall m.
MonadError Error m =>
MonadAff m =>
(Request Unit -> m Response) ->
IncomingMessage IMServer ->
ServerResponse ->
Effect Unit
m Unit
handleRequestUnit router request httpresponse =
void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request
void $ fromHTTPRequestUnit request
>>= (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`)
-- | `m Response`)
-- | * 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
-- | request, extracts the `Response` from the `m Response`, and sends the
-- | `Response` to the HTTP `Response`.
handleExtRequest ::
forall ctx ctxRL thru route.
forall m ctx ctxRL thru route.
MonadError Error m =>
MonadAff m =>
Union ctx thru ctx =>
RowToList ctx ctxRL =>
Keys ctx =>
Nub (RequestR route ctx) (RequestR route ctx) =>
{ route :: RD.RouteDuplex' route
, router :: ExtRequestNT route ctx -> ResponseM
, notFoundHandler :: Request Unit -> ResponseM
, router :: ExtRequestNT route ctx -> m Response
, notFoundHandler :: Request Unit -> m Response
} ->
IncomingMessage IMServer ->
ServerResponse ->
Aff Unit
m Unit
handleExtRequest { route, router, notFoundHandler } req resp = do
httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req
httpurpleResp <- (notFoundHandler ||| onError500 router) httpurpleReq
send resp httpurpleResp
handleRequest ::
forall ctx ctxRL thru route.
forall ctx ctxRL thru route m.
MonadAff m =>
MonadError Error m =>
Union ctx thru ctx =>
RowToList ctx ctxRL =>
Keys ctx =>
Nub (RequestR route ctx) (RequestR route ctx) =>
{ route :: RD.RouteDuplex' route
, router :: ExtRequestNT route ctx -> ResponseM
, notFoundHandler :: Request Unit -> ResponseM
, router :: ExtRequestNT route ctx -> m Response
, notFoundHandler :: Request Unit -> m Response
} ->
IncomingMessage IMServer ->
ServerResponse ->
Effect Unit
handleRequest settings request response = void $ runAff (\_ -> pure unit) $ handleExtRequest settings request response
m Unit
handleRequest settings request response = void $ handleExtRequest settings request response
handleExtRequestWithMiddleware ::
forall input output outputRL thru route.
forall input output outputRL thru route m.
MonadAff m =>
MonadError Error m =>
Union output thru output =>
RowToList output outputRL =>
Keys output =>
Nub (RequestR route output) (RequestR route output) =>
{ route :: RD.RouteDuplex' route
, nodeMiddleware :: NodeMiddlewareStack input output
, router :: ExtRequestNT route output -> ResponseM
, notFoundHandler :: Request Unit -> ResponseM
, router :: ExtRequestNT route output -> m Response
, notFoundHandler :: Request Unit -> m Response
} ->
IncomingMessage IMServer ->
ServerResponse ->
Effect Unit
handleExtRequestWithMiddleware { route, nodeMiddleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do
m Unit
handleExtRequestWithMiddleware { route, nodeMiddleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ 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 output -> m Unit
executeHandler (MiddlewareResult { request, response, middlewareResult: ProcessingFailed error }) =
liftEffect $ handleRequestUnit (defaultMiddlewareErrorHandler error) request response
handleRequestUnit (defaultMiddlewareErrorHandler 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 m. MonadAff m => Request route -> m Response
defaultNotFoundHandler = const notFound
asExtended ::
@ -190,25 +201,28 @@ asExtended ::
asExtended = lcmap unwrap
serveInternal ::
forall route from fromRL via missing missingList input output outputRL thru.
forall m route from fromRL via missing missingList input output outputRL thru.
MonadAff m =>
MonadError Error m =>
RowToList missing missingList =>
FillableFields missingList () missing =>
Union via missing (ListenOptionsR) =>
Union via missing (ListenOptionsR m) =>
RowToList from fromRL =>
JustifiableFields fromRL from () via =>
Union output thru output =>
RowToList output outputRL =>
KeysRL outputRL =>
Nub (RequestR route output) (RequestR route output) =>
(m Unit -> Aff Unit) ->
{ | from } ->
Maybe (NodeMiddlewareStack input output) ->
{ route :: RD.RouteDuplex' route
, router :: ExtRequestNT route output -> ResponseM
, router :: ExtRequestNT route output -> m Response
} ->
ServerM
serveInternal inputOptions maybeNodeMiddleware settings = do
serveInternal performM inputOptions maybeNodeMiddleware settings = do
let
filledOptions :: ListenOptions
filledOptions :: ListenOptions m
filledOptions = justifill inputOptions
host = fromMaybe defaultHostname filledOptions.hostname
@ -221,52 +235,70 @@ serveInternal inputOptions maybeNodeMiddleware settings = do
, backlog: fromMaybe 511 filledOptions.backlog
}
routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler $ filledOptions.notFoundHandler }
handler = case maybeNodeMiddleware of
Just nodeMiddleware -> handleExtRequestWithMiddleware $ merge routingSettings { nodeMiddleware }
Nothing -> handleRequest routingSettings
handler req rep = launchAff_ $ performM $ case maybeNodeMiddleware of
Just nodeMiddleware -> handleExtRequestWithMiddleware (merge routingSettings { nodeMiddleware }) req rep
Nothing -> handleRequest routingSettings req rep
sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile
netServer <- case sslOptions of
Just { certFile, keyFile } -> do
cert' <- readFile certFile
key' <- readFile keyFile
server <- HTTPS.createSecureServer'
cert' <- liftEffect $ readFile certFile
key' <- liftEffect $ readFile keyFile
server <- liftEffect $ HTTPS.createSecureServer'
{ key: [ key' ]
, cert: [ cert' ]
}
server # EE.on_ HServer.requestH handler
liftEffect $ EE.on_ HServer.requestH handler server
pure $ HServer.toNetServer server
Nothing -> do
server <- HTTP.createServer
server # EE.on_ HServer.requestH handler
server <- liftEffect $ HTTP.createServer
liftEffect $ EE.on_ HServer.requestH handler server
pure $ HServer.toNetServer server
netServer # EE.on_ listeningH onStarted
listenTcp netServer options
liftEffect $ EE.on_ listeningH (launchAff_ $ performM onStarted) netServer
liftEffect $ listenTcp netServer options
let closingHandler = NServer.close netServer
liftEffect $ registerClosingHandler filledOptions.closingHandler (\eff -> eff *> closingHandler)
srv <- registerClosingHandler filledOptions.closingHandler (\eff -> eff *> closingHandler)
liftEffect srv
serve ::
forall route from fromRL via missing missingList.
RowToList missing missingList =>
FillableFields missingList () missing =>
Union via missing (ListenOptionsR) =>
Union via missing (ListenOptionsR Aff) =>
RowToList from fromRL =>
JustifiableFields fromRL from () via =>
{ | from } ->
BasicRoutingSettings route ->
BasicRoutingSettings Aff route ->
ServerM
serve inputOptions { route, router } = do
let
extendedSettings = { route, router: asExtended router }
serveInternal identity inputOptions Nothing extendedSettings
serveInternal inputOptions Nothing extendedSettings
serve' ::
forall m route from fromRL via missing missingList.
MonadAff m =>
MonadError Error m =>
RowToList missing missingList =>
FillableFields missingList () missing =>
Union via missing (ListenOptionsR m) =>
RowToList from fromRL =>
JustifiableFields fromRL from () via =>
(m Unit -> Aff Unit) ->
{ | from } ->
BasicRoutingSettings m route ->
ServerM
serve' ma inputOptions { route, router } = do
let
extendedSettings = { route, router: asExtended router }
serveInternal ma inputOptions Nothing extendedSettings
serveNodeMiddleware ::
forall route from fromRL via missing missingList input output outputRL thru.
RowToList missing missingList =>
FillableFields missingList () missing =>
Union via missing (ListenOptionsR) =>
Union via missing (ListenOptionsR Aff) =>
RowToList from fromRL =>
JustifiableFields fromRL from () via =>
Union output thru output =>
@ -274,17 +306,17 @@ serveNodeMiddleware ::
KeysRL outputRL =>
Nub (RequestR route output) (RequestR route output) =>
{ | from } ->
ExtRoutingSettings route input output ->
ExtRoutingSettings Aff route input output ->
ServerM
serveNodeMiddleware inputOptions { route, router, nodeMiddleware } = do
let
extendedSettings = { route, router: asExtended router }
serveInternal inputOptions (Just nodeMiddleware) extendedSettings
serveInternal identity inputOptions (Just nodeMiddleware) extendedSettings
registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM
registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler
registerClosingHandler _ closingHandler = do
registerClosingHandler :: forall m. MonadEffect m => Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> m ServerM
registerClosingHandler (Just NoClosingHandler) closingHandler = pure $ pure closingHandler
registerClosingHandler _ closingHandler = pure $ liftEffect do
Process.process # EE.on_ (mkSignalH SIGINT) (closingHandler $ log "Aye, stopping service now. Goodbye!")
Process.process # EE.on_ (mkSignalH SIGTERM) (closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye...")
pure closingHandler
@ -295,5 +327,5 @@ defaultHostname = "0.0.0.0"
defaultPort :: Int
defaultPort = 8080
defaultOnStart :: String -> Int -> Effect Unit
defaultOnStart hostname port = log $ "HTTPurple 🪁 up and running on http://" <> hostname <> ":" <> show port
defaultOnStart :: forall m. MonadEffect m => String -> Int -> m Unit
defaultOnStart hostname port = liftEffect $ log $ "HTTPurple 🪁 up and running on http://" <> hostname <> ":" <> show port