Make settings optional
- Add default onStarted and closingHandler - Use justifill to easily add options - Remove multiple serve options
This commit is contained in:
parent
c16eb2bdcc
commit
345675d5bd
@ -30,7 +30,9 @@ router { route: SayHello } = readTextFile UTF8 filePath >>= ok
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌────────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -28,7 +28,9 @@ router { body } = toBuffer body >>= sha256sum >>> ok
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌─────────────────────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -32,7 +32,9 @@ router = const $ readFile filePath >>= ok' responseHeaders
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌──────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -34,7 +34,9 @@ router = const $ runScript "echo 'hello '; sleep 1; echo 'world!'" >>= ok
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌──────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -42,7 +42,9 @@ sayHello _ = do
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router: readerMiddleware sayHello, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router: readerMiddleware sayHello }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌───────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -18,7 +18,6 @@ route = RD.root $ RG.sum
|
||||
{ "SayHello": RG.noArgs
|
||||
}
|
||||
|
||||
|
||||
-- | The headers that will be included in every response.
|
||||
responseHeaders :: Headers
|
||||
responseHeaders = header "X-Example" "hello world!"
|
||||
@ -30,7 +29,9 @@ router { headers } = ok' responseHeaders $ headers !@ "X-Input"
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing} do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌──────────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -21,7 +21,9 @@ route = RD.root $ RG.sum
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router: const $ ok "hello world!", notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router: const $ ok "hello world!" }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌────────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -23,7 +23,6 @@ middlewareRoute = RD.root $ RG.sum
|
||||
{ "Middleware": "middleware" / RG.noArgs
|
||||
}
|
||||
|
||||
|
||||
data SayHello = SayHello
|
||||
|
||||
derive instance Generic SayHello _
|
||||
@ -34,7 +33,8 @@ sayHelloRoute = RD.root $ RG.sum
|
||||
}
|
||||
|
||||
-- | A middleware that logs at the beginning and end of each request
|
||||
loggingMiddleware :: forall route.
|
||||
loggingMiddleware ::
|
||||
forall route.
|
||||
(Request route -> ResponseM) ->
|
||||
Request route ->
|
||||
ResponseM
|
||||
@ -48,7 +48,8 @@ loggingMiddleware router request = do
|
||||
|
||||
-- | A middleware that adds the X-Middleware header to the response, if it
|
||||
-- | wasn't already in the response
|
||||
headerMiddleware :: forall route.
|
||||
headerMiddleware ::
|
||||
forall route.
|
||||
(Request route -> ResponseM) ->
|
||||
Request route ->
|
||||
ResponseM
|
||||
@ -60,14 +61,14 @@ headerMiddleware router request = do
|
||||
|
||||
-- | A middleware that sends the body "Middleware!" instead of running the
|
||||
-- | router when requesting /middleware
|
||||
pathMiddleware :: forall route.
|
||||
pathMiddleware ::
|
||||
forall route.
|
||||
(Request route -> ResponseM) ->
|
||||
Request (Middleware <+> route ) ->
|
||||
Request (Middleware <+> route) ->
|
||||
ResponseM
|
||||
pathMiddleware _ { route: Left Middleware } = ok "Middleware!"
|
||||
pathMiddleware router request@{ route: Right r } = router $ Record.set (Proxy :: _ "route") r request
|
||||
|
||||
|
||||
-- | Say 'hello' when run, and add a default value to the X-Middleware header
|
||||
sayHello :: Request SayHello -> ResponseM
|
||||
sayHello _ = ok' (header "X-Middleware" "router") "hello"
|
||||
@ -79,7 +80,9 @@ middlewareStack = loggingMiddleware <<< headerMiddleware <<< pathMiddleware
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route: middlewareRoute <+> sayHelloRoute , router: middlewareStack sayHello, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route: middlewareRoute <+> sayHelloRoute, router: middlewareStack sayHello }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌───────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -29,7 +29,9 @@ router { route: GoodBye } = ok "goodbye"
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -30,7 +30,9 @@ router { route: ManySegments elems } = ok $ show elems
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌───────────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -27,7 +27,9 @@ router _ = notFound
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted = do
|
||||
log " ┌───────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -4,6 +4,7 @@ import Prelude
|
||||
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Effect (Effect)
|
||||
import Effect.Class.Console (log)
|
||||
import HTTPurple (Request, ResponseM, ServerM, notFound, ok, serve)
|
||||
import Routing.Duplex (RouteDuplex')
|
||||
@ -30,7 +31,10 @@ router _ = notFound
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serve 8080 { route, router, notFoundHandler: Nothing } do
|
||||
serve { port: 8080, onStarted } { route, router }
|
||||
where
|
||||
onStarted :: Effect Unit
|
||||
onStarted = do
|
||||
log " ┌───────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
|
@ -5,7 +5,7 @@ import Prelude
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Effect.Console (log)
|
||||
import HTTPurple (Request, ResponseM, ServerM, ok, serveSecure)
|
||||
import HTTPurple (Request, ResponseM, ServerM, ok, serve)
|
||||
import Routing.Duplex (RouteDuplex')
|
||||
import Routing.Duplex as RD
|
||||
import Routing.Duplex.Generic as G
|
||||
@ -35,11 +35,14 @@ sayHello _ = ok "hello world!"
|
||||
-- | Boot up the server
|
||||
main :: ServerM
|
||||
main =
|
||||
serveSecure 8080 cert key { route, router: sayHello, notFoundHandler: Nothing } do
|
||||
log " ┌───────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
log " │ To test, run: │"
|
||||
log " │ > curl --insecure https://localhost:8080 │"
|
||||
log " │ # => hello world! │"
|
||||
log " └───────────────────────────────────────────┘"
|
||||
serve { port: 8080, certFile: cert, keyFile: key, onStarted } { route, router: sayHello }
|
||||
where
|
||||
onStarted =
|
||||
do
|
||||
log " ┌───────────────────────────────────────────┐"
|
||||
log " │ Server now up on port 8080 │"
|
||||
log " │ │"
|
||||
log " │ To test, run: │"
|
||||
log " │ > curl --insecure https://localhost:8080 │"
|
||||
log " │ # => hello world! │"
|
||||
log " └───────────────────────────────────────────┘"
|
||||
|
@ -10,14 +10,18 @@
|
||||
, "foldable-traversable"
|
||||
, "foreign-object"
|
||||
, "js-uri"
|
||||
, "justifill"
|
||||
, "maybe"
|
||||
, "newtype"
|
||||
, "node-buffer"
|
||||
, "node-fs"
|
||||
, "node-http"
|
||||
, "node-net"
|
||||
, "node-process"
|
||||
, "node-streams"
|
||||
, "options"
|
||||
, "ordered-collections"
|
||||
, "posix-types"
|
||||
, "prelude"
|
||||
, "profunctor"
|
||||
, "record"
|
||||
|
@ -20,6 +20,6 @@ import HTTPurple.Path (Path)
|
||||
import HTTPurple.Query (Query)
|
||||
import HTTPurple.Request (Request, 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 (<+>), combineRoutes, (<+>))
|
||||
import HTTPurple.Server (ServerM, serve, serve', serveSecure, serveSecure')
|
||||
import HTTPurple.Routes (type (<+>), combineRoutes, orElse, (<+>))
|
||||
import HTTPurple.Server (ServerM, serve)
|
||||
import HTTPurple.Status (Status)
|
||||
|
@ -1,28 +1,38 @@
|
||||
module HTTPurple.Server
|
||||
( ServerM
|
||||
( ClosingHandler(..)
|
||||
, ListenOptions
|
||||
, ListenOptionsR
|
||||
, RoutingSettings
|
||||
, RoutingSettingsR
|
||||
, ServerM
|
||||
, serve
|
||||
, serve'
|
||||
, serveSecure
|
||||
, serveSecure'
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Maybe (Maybe(Nothing), maybe)
|
||||
import Data.Options (Options, (:=))
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Options ((:=))
|
||||
import Data.Posix.Signal (Signal(..))
|
||||
import Data.Profunctor.Choice ((|||))
|
||||
import Effect (Effect)
|
||||
import Effect.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 Justifill (justifill)
|
||||
import Justifill.Fillable (class FillableFields)
|
||||
import Justifill.Justifiable (class JustifiableFields)
|
||||
import Node.Encoding (Encoding(UTF8))
|
||||
import Node.FS.Sync (readTextFile)
|
||||
import Node.HTTP (ListenOptions, close, listen)
|
||||
import Node.HTTP (Request, Response, createServer) as HTTP
|
||||
import Node.HTTP.Secure (SSLOptions, cert, certString, key, keyString)
|
||||
import Node.HTTP (ListenOptions, Request, Response, createServer) as HTTP
|
||||
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.RowList (class RowToList)
|
||||
import Routing.Duplex as RD
|
||||
|
||||
-- | The `ServerM` is just an `Effect` containing a callback to close the
|
||||
@ -30,11 +40,27 @@ import Routing.Duplex as RD
|
||||
-- | methods.
|
||||
type ServerM = Effect (Effect Unit -> Effect Unit)
|
||||
|
||||
type RoutingSettings route =
|
||||
{ route :: RD.RouteDuplex' route
|
||||
, router :: Request route -> ResponseM
|
||||
data ClosingHandler = DefaultClosingHandler | NoClosingHandler
|
||||
|
||||
type ListenOptionsR =
|
||||
( hostname :: Maybe String
|
||||
, port :: Maybe Int
|
||||
, backlog :: Maybe Int
|
||||
, closingHandler :: Maybe ClosingHandler
|
||||
, notFoundHandler :: Maybe (Request Unit -> ResponseM)
|
||||
}
|
||||
, onStarted :: Maybe (Effect Unit)
|
||||
, certFile :: Maybe String
|
||||
, keyFile :: Maybe String
|
||||
)
|
||||
|
||||
type ListenOptions = { | ListenOptionsR }
|
||||
|
||||
type RoutingSettingsR route =
|
||||
( route :: RD.RouteDuplex' route
|
||||
, router :: Request route -> ResponseM
|
||||
)
|
||||
|
||||
type RoutingSettings route = { | RoutingSettingsR route }
|
||||
|
||||
-- | Given a router, handle unhandled exceptions it raises by
|
||||
-- | responding with 500 Internal Server Error.
|
||||
@ -65,74 +91,74 @@ handleRequest { route, router, notFoundHandler } request httpresponse =
|
||||
defaultNotFoundHandler :: forall route. Request route -> ResponseM
|
||||
defaultNotFoundHandler = const notFound
|
||||
|
||||
-- | Given a `ListenOptions` object, a function mapping `Request` to
|
||||
-- | `ResponseM`, and a `ServerM` containing effects to run on boot, creates and
|
||||
-- | runs a HTTPurple server without SSL.
|
||||
serve' ::
|
||||
forall route.
|
||||
ListenOptions ->
|
||||
RoutingSettings route ->
|
||||
Effect Unit ->
|
||||
ServerM
|
||||
serve' options { route, router, notFoundHandler } onStarted = do
|
||||
server <- HTTP.createServer (handleRequest { route, router, notFoundHandler: maybe defaultNotFoundHandler identity notFoundHandler })
|
||||
listen server options onStarted
|
||||
pure $ close server
|
||||
justifillListenOptions ::
|
||||
forall from fromRL via missing missingList.
|
||||
RowToList missing missingList =>
|
||||
FillableFields missingList () missing =>
|
||||
Union via missing (ListenOptionsR) =>
|
||||
RowToList from fromRL =>
|
||||
JustifiableFields fromRL from () via =>
|
||||
{ | from } ->
|
||||
ListenOptions
|
||||
justifillListenOptions = justifill
|
||||
|
||||
-- | Given a `Options HTTPS.SSLOptions` object and a `HTTP.ListenOptions`
|
||||
-- | object, a function mapping `Request` to `ResponseM`, and a `ServerM`
|
||||
-- | containing effects to run on boot, creates and runs a HTTPurple server with
|
||||
-- | SSL.
|
||||
serveSecure' ::
|
||||
forall route.
|
||||
Options SSLOptions ->
|
||||
ListenOptions ->
|
||||
RoutingSettings route ->
|
||||
Effect Unit ->
|
||||
ServerM
|
||||
serveSecure' sslOptions options { route, router, notFoundHandler } onStarted = do
|
||||
server <- HTTPS.createServer sslOptions (handleRequest { route, router, notFoundHandler: maybe defaultNotFoundHandler identity notFoundHandler })
|
||||
listen server options onStarted
|
||||
pure $ close server
|
||||
|
||||
-- | Given a port number, return a `HTTP.ListenOptions` `Record`.
|
||||
listenOptions :: Int -> ListenOptions
|
||||
listenOptions port =
|
||||
{ hostname: "0.0.0.0"
|
||||
, port
|
||||
, backlog: Nothing
|
||||
}
|
||||
|
||||
-- | Create and start a server. This is the main entry point for HTTPurple. Takes
|
||||
-- | a port number on which to listen, a function mapping `Request` to
|
||||
-- | `ResponseM`, and a `ServerM` containing effects to run after the server has
|
||||
-- | booted (usually logging). Returns an `ServerM` containing the server's
|
||||
-- | effects.
|
||||
-- | Given a `ListenOptions` and a `RoutingSettings`, creates and
|
||||
-- | runs a HTTPurple server.
|
||||
serve ::
|
||||
forall route.
|
||||
Int ->
|
||||
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 ->
|
||||
Effect Unit ->
|
||||
ServerM
|
||||
serve = serve' <<< listenOptions
|
||||
serve inputOptions { route, router } = do
|
||||
let
|
||||
filledOptions :: ListenOptions
|
||||
filledOptions = justifillListenOptions inputOptions
|
||||
|
||||
-- | Create and start an SSL server. This method is the same as `serve`, but
|
||||
-- | takes additional SSL arguments. The arguments in order are:
|
||||
-- | 1. A port number
|
||||
-- | 2. A path to a cert file
|
||||
-- | 3. A path to a private key file
|
||||
-- | 4. A handler method which maps `Request` to `ResponseM`
|
||||
-- | 5. A callback to call when the server is up
|
||||
serveSecure ::
|
||||
forall route.
|
||||
Int ->
|
||||
String ->
|
||||
String ->
|
||||
RoutingSettings route ->
|
||||
Effect Unit ->
|
||||
ServerM
|
||||
serveSecure port certFile keyFile routingSettings onStarted = do
|
||||
cert' <- readTextFile UTF8 certFile
|
||||
key' <- readTextFile UTF8 keyFile
|
||||
let sslOpts = key := keyString key' <> cert := certString cert'
|
||||
serveSecure' sslOpts (listenOptions port) routingSettings onStarted
|
||||
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
|
||||
case filledOptions.closingHandler of
|
||||
Just NoClosingHandler -> pure closingHandler
|
||||
_ -> do
|
||||
onSignal SIGINT $ closingHandler $ log "Received SIGINT, stopping service now."
|
||||
onSignal SIGTERM $ closingHandler $ log "Received SIGTERM, stopping service now."
|
||||
pure closingHandler
|
||||
|
||||
defaultHostname :: String
|
||||
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
|
||||
|
@ -12,7 +12,8 @@ import Effect.Exception (error)
|
||||
import Foreign.Object (empty)
|
||||
import HTTPurple.Request (Request)
|
||||
import HTTPurple.Response (ResponseM, notFound, ok)
|
||||
import HTTPurple.Server (serve, serve', serveSecure, serveSecure')
|
||||
import HTTPurple.Server (serve)
|
||||
import HTTPurple.Server as Server
|
||||
import Node.Encoding (Encoding(UTF8))
|
||||
import Node.FS.Sync (readTextFile)
|
||||
import Node.HTTP.Secure (key, keyString, cert, certString)
|
||||
@ -40,13 +41,13 @@ serveSpec :: Test
|
||||
serveSpec =
|
||||
describe "serve" do
|
||||
it "boots a server on the given port" do
|
||||
close <- liftEffect $ serve 8080 { route, router: mockRouter, notFoundHandler: Nothing } $ pure unit
|
||||
close <- liftEffect $ serve { port: 8080 } { route, router: mockRouter }
|
||||
out <- get 8080 empty "/test"
|
||||
liftEffect $ close $ pure unit
|
||||
out ?= "/test"
|
||||
it "responds with a 500 upon unhandled exceptions" do
|
||||
let router _ = throwError $ error "fail!"
|
||||
close <- liftEffect $ serve 8080 { route, router, notFoundHandler: Nothing } $ pure unit
|
||||
close <- liftEffect $ serve { port: 8080 } { route, router }
|
||||
status <- getStatus 8080 empty "/test"
|
||||
liftEffect $ close $ pure unit
|
||||
status ?= 500
|
||||
@ -55,11 +56,9 @@ serve'Spec :: Test
|
||||
serve'Spec =
|
||||
describe "serve'" do
|
||||
it "boots a server with the given options" do
|
||||
let options = { hostname: "localhost", port: 8080, backlog: Nothing }
|
||||
close <-
|
||||
liftEffect
|
||||
$ serve' options { route, router: mockRouter, notFoundHandler: Nothing }
|
||||
$ pure unit
|
||||
$ serve { hostname: "localhost", port: 8080 } { route, router: mockRouter }
|
||||
out <- get 8080 empty "/test"
|
||||
liftEffect $ close $ pure unit
|
||||
out ?= "/test"
|
||||
@ -71,16 +70,14 @@ serveSecureSpec =
|
||||
it "boots a server on the given port" do
|
||||
close <-
|
||||
liftEffect
|
||||
$ serveSecure 8080 "./test/Mocks/Certificate.cer" "./test/Mocks/Key.key" { route, router: mockRouter, notFoundHandler: Nothing }
|
||||
$ pure unit
|
||||
$ serve { port: 8080, certFile: "./test/Mocks/Certificate.cer", keyFile: "./test/Mocks/Key.key" } { route, router: mockRouter }
|
||||
out <- get' 8080 empty "/test"
|
||||
liftEffect $ close $ pure unit
|
||||
out ?= "/test"
|
||||
describe "with invalid key and cert files" do
|
||||
it "throws" do
|
||||
expectError $ liftEffect
|
||||
$ serveSecure 8080 "" "" { route, router: mockRouter, notFoundHandler: Nothing }
|
||||
$ pure unit
|
||||
$ serve { port: 8080, certFile: "", keyFile: "" } { route, router: mockRouter }
|
||||
|
||||
serveSecure'Spec :: Test
|
||||
serveSecure'Spec =
|
||||
@ -88,16 +85,10 @@ serveSecure'Spec =
|
||||
describe "with valid key and cert files" do
|
||||
it "boots a server on the given port" do
|
||||
let
|
||||
options = { hostname: "localhost", port: 8080, backlog: Nothing }
|
||||
sslOptions = do
|
||||
cert' <- readTextFile UTF8 "./test/Mocks/Certificate.cer"
|
||||
key' <- readTextFile UTF8 "./test/Mocks/Key.key"
|
||||
pure $ key := keyString key' <> cert := certString cert'
|
||||
sslOpts <- liftEffect $ sslOptions
|
||||
options = { hostname: "localhost", port: 8080, certFile: "./test/Mocks/Certificate.cer", keyFile: "./test/Mocks/Key.key" }
|
||||
close <-
|
||||
liftEffect
|
||||
$ serveSecure' sslOpts options { route, router: mockRouter, notFoundHandler: Nothing }
|
||||
$ pure unit
|
||||
$ serve options { route, router: mockRouter }
|
||||
out <- get' 8080 empty "/test"
|
||||
liftEffect $ close $ pure unit
|
||||
out ?= "/test"
|
||||
|
Loading…
Reference in New Issue
Block a user