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

First working example of routing duplex

Browse Source
This commit is contained in:
sigma-andex 2022-05-05 16:51:43 +01:00
parent 2286472305
commit 24197a474a
6 changed files with 148 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
Readme.md
View File

@ -1,29 +1,11 @@
# HTTPure
# HTTPurple 🪁
[![License](https://img.shields.io/badge/license-MIT-blue.svg)](https://raw.githubusercontent.com/cprussin/purescript-httpure/main/License)
[![Latest release](http://img.shields.io/github/release/cprussin/purescript-httpure.svg)](https://github.com/cprussin/purescript-httpure/releases)
[![License](https://img.shields.io/badge/license-MIT-blue.svg)](https://raw.githubusercontent.com/sigma-andex/purescript-httpurple/main/License)
[![Latest release](http://img.shields.io/github/release/sigma-andex/purescript-httpurple.svg)](https://github.com/sigma-andex/purescript-httpurple/releases)
[![purescript-httpure on Pursuit](https://pursuit.purescript.org/packages/purescript-httpure/badge)](https://pursuit.purescript.org/packages/purescript-httpure)
A purescript HTTP server framework.
A 🎨 colourful fork of the amazing [HTTPure](https://github.com/citizennet/purescript-httpure) http server framework.
HTTPure is:
- Well-tested (see our [tests](./test/Test))
- Well-documented (see our [documentation](./docs))
- Built to take advantage of PureScript language features for flexible and
extensible routing
- Pure (no `set`, `get`, `use`, etc)
## Status
This project is currently fairly stable, but has not reached it's 1.0 release
yet. You can track what's left before it gets there by looking at our
[roadmap](https://github.com/cprussin/purescript-httpure/projects). The API
signatures are _mostly_ stable, but are subject to change before the 1.0 release
if there's a good reason to change them.
If you'd like to help us get to 1.0 quicker, please contribute! To get started,
check our [contributing guide](./Contributing.md).
## Installation
@ -59,10 +41,6 @@ You can also take a look at [our guides](./docs).
HTTPure ships with a number of [examples](./docs/Examples). To run an example,
in the project root, run:
```bash
nix-shell --run 'example <Example Name>'
```
Or, without `nix`:
```bash
@ -77,29 +55,9 @@ the example server.
To run the test suite, in the project root run:
```bash
nix-shell --run check
spago -x test.dhall test
```
Or, if `nix` isn't your thing:
```bash
purs-tidy check src test docs && spago -x test.dhall test
```
## Contributing
We are open to accepting contributions! Please see
the [contributing guide](Contributing.md).
## People
HTTPure is written and maintained
by [Connor Prussin](https://connor.prussin.net) and [Petri
Lehtinen](http://www.digip.org/).
We are open to accepting contributions! Please see
the [contributing guide](./Contributing.md).
## License
[MIT](./License)

144
src/HTTPure.purs
View File

@ -4,6 +4,7 @@ module HTTPure
, module HTTPure.Lookup
, module HTTPure.Method
, module HTTPure.Path
, module HTTPure.Routes
, module HTTPure.Query
, module HTTPure.Request
, module HTTPure.Response
@ -16,146 +17,9 @@ import HTTPure.Headers (Headers, empty, header, headers)
import HTTPure.Lookup (at, has, lookup, (!!), (!?), (!@))
import HTTPure.Method (Method(..))
import HTTPure.Path (Path)
import HTTPure.Routes (combineRoutes, (<+>))
import HTTPure.Query (Query)
import HTTPure.Request (Request, fullPath)
import HTTPure.Response
( Response
, ResponseM
, accepted
, accepted'
, alreadyReported
, alreadyReported'
-- 1xx
, badGateway
, badGateway'
, badRequest
, badRequest'
, conflict
, conflict'
-- 2xx
, continue
, continue'
, created
, created'
, emptyResponse
, emptyResponse'
, expectationFailed
, expectationFailed'
, failedDependency
, failedDependency'
, forbidden
, forbidden'
, found
, found'
, gatewayTimeout
, gatewayTimeout'
, gone
, gone'
, hTTPVersionNotSupported
, hTTPVersionNotSupported'
-- 3xx
, iMUsed
, iMUsed'
, imATeapot
, imATeapot'
, insufficientStorage
, insufficientStorage'
, internalServerError
, internalServerError'
, lengthRequired
, lengthRequired'
, locked
, locked'
, loopDetected
, loopDetected'
, methodNotAllowed
, methodNotAllowed'
-- 4xx
, 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'
-- 5xx
, switchingProtocols
, switchingProtocols'
, temporaryRedirect
, temporaryRedirect'
, tooManyRequests
, tooManyRequests'
, uRITooLong
, uRITooLong'
, unauthorized
, unauthorized'
, unavailableForLegalReasons
, unavailableForLegalReasons'
, unprocessableEntity
, unprocessableEntity'
, unsupportedMediaType
, unsupportedMediaType'
, upgradeRequired
, upgradeRequired'
, useProxy
, useProxy'
, variantAlsoNegotiates
, variantAlsoNegotiates'
)
import HTTPure.Server
( ServerM
, serve
, serve'
, serveSecure
, serveSecure'
)
import HTTPure.Response (Response, ResponseM, response, response', emptyResponse, emptyResponse', continue, continue', switchingProtocols, switchingProtocols', processing, processing', ok, ok', created, created', accepted, accepted', nonAuthoritativeInformation, nonAuthoritativeInformation', noContent, noContent', resetContent, resetContent', partialContent, partialContent', multiStatus, multiStatus', alreadyReported, alreadyReported', iMUsed, iMUsed', multipleChoices, multipleChoices', movedPermanently, movedPermanently', found, found', seeOther, seeOther', notModified, notModified', useProxy, useProxy', temporaryRedirect, temporaryRedirect', permanentRedirect, permanentRedirect', badRequest, badRequest', unauthorized, unauthorized', paymentRequired, paymentRequired', forbidden, forbidden', notFound, notFound', methodNotAllowed, methodNotAllowed', notAcceptable, notAcceptable', proxyAuthenticationRequired, proxyAuthenticationRequired', requestTimeout, requestTimeout', conflict, conflict', gone, gone', lengthRequired, lengthRequired', preconditionFailed, preconditionFailed', payloadTooLarge, payloadTooLarge', uRITooLong, uRITooLong', unsupportedMediaType, unsupportedMediaType', rangeNotSatisfiable, rangeNotSatisfiable', expectationFailed, expectationFailed', imATeapot, imATeapot', misdirectedRequest, misdirectedRequest', unprocessableEntity, unprocessableEntity', locked, locked', failedDependency, failedDependency', upgradeRequired, upgradeRequired', preconditionRequired, preconditionRequired', tooManyRequests, tooManyRequests', requestHeaderFieldsTooLarge, requestHeaderFieldsTooLarge', unavailableForLegalReasons, unavailableForLegalReasons', internalServerError, internalServerError', notImplemented, notImplemented', badGateway, badGateway', serviceUnavailable, serviceUnavailable', gatewayTimeout, gatewayTimeout', hTTPVersionNotSupported, hTTPVersionNotSupported', variantAlsoNegotiates, variantAlsoNegotiates', insufficientStorage, insufficientStorage', loopDetected, loopDetected', notExtended, notExtended', networkAuthenticationRequired, networkAuthenticationRequired')
import HTTPure.Server (ServerM, serve, serve')
import HTTPure.Status (Status)

34
src/HTTPure/Request.purs
View File

@ -6,6 +6,8 @@ module HTTPure.Request
import Prelude
import Data.Bifunctor (bimap)
import Data.Either (Either)
import Data.String (joinWith)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
@ -25,13 +27,15 @@ import HTTPure.Version (Version)
import HTTPure.Version (read) as Version
import Node.HTTP (Request) as HTTP
import Node.HTTP (requestURL)
import Routing.Duplex as RD
-- | The `Request` type is a `Record` type that includes fields for accessing
-- | the different parts of the HTTP request.
type Request =
type Request route =
{ method :: Method
, path :: Path
, query :: Query
, route :: route
, headers :: Headers
, body :: RequestBody
, httpVersion :: Version
@ -41,7 +45,7 @@ type Request =
-- | 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 :: Request -> String
fullPath :: forall route. Request route -> String
fullPath request = "/" <> path <> questionMark <> queryParams
where
path = joinWith "/" request.path
@ -52,16 +56,20 @@ fullPath request = "/" <> path <> questionMark <> queryParams
-- | Given an HTTP `Request` object, this method will convert it to an HTTPure
-- | `Request` object.
fromHTTPRequest :: HTTP.Request -> Aff Request
fromHTTPRequest request = do
fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
fromHTTPRequest route request = do
body <- liftEffect $ Body.read request
pure
{ method: Method.read request
, path: Path.read request
, query: Query.read request
, headers: Headers.read request
, body
, httpVersion: Version.read request
, url: requestURL 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)

24
src/HTTPure/Routes.purs Normal file
View File

@ -0,0 +1,24 @@
module HTTPure.Routes
( (<+>)
, combineRoutes
)
where
import Prelude
import Control.Alt ((<|>))
import Data.Either (Either(..))
import Data.Profunctor.Choice ((|||))
import Routing.Duplex as RD
combineRoutes ::
forall left right.
RD.RouteDuplex' left ->
RD.RouteDuplex' right ->
RD.RouteDuplex' (Either left right)
combineRoutes (RD.RouteDuplex lEnc lDec) (RD.RouteDuplex rEnc rDec) = (RD.RouteDuplex enc dec)
where
enc = lEnc ||| rEnc
dec = (lDec <#> Left) <|> (rDec <#> Right)
infixr 3 combineRoutes as <+>

105
src/HTTPure/Server.purs
View File

@ -2,26 +2,28 @@ module HTTPure.Server
( ServerM
, serve
, serve'
, serveSecure
, serveSecure'
-- , serveSecure
-- , serveSecure'
) where
import Prelude
import Data.Maybe (Maybe(Nothing))
import Data.Options (Options, (:=))
import Data.Maybe (Maybe(Nothing), maybe)
import Data.Options ((:=), Options)
import Data.Profunctor.Choice ((|||))
import Effect (Effect)
import Effect.Aff (catchError, message, runAff)
import Effect.Class (liftEffect)
import Effect.Console (error)
import HTTPure.Request (Request, fromHTTPRequest)
import HTTPure.Response (ResponseM, internalServerError, send)
import HTTPure.Response (ResponseM, internalServerError, notFound, send)
import Node.Encoding (Encoding(UTF8))
import Node.FS.Sync (readTextFile)
import Node.HTTP (ListenOptions, close, listen)
import Node.HTTP (ListenOptions, listen, close)
import Node.HTTP (Request, Response, createServer) as HTTP
import Node.HTTP.Secure (SSLOptions, cert, certString, key, keyString)
import Node.HTTP.Secure (SSLOptions, key, keyString, cert, certString)
import Node.HTTP.Secure (createServer) as HTTPS
import Routing.Duplex as RD
-- | The `ServerM` is just an `Effect` containing a callback to close the
-- | server. This type is the return type of the HTTPure serve and related
@ -30,7 +32,7 @@ type ServerM = Effect (Effect Unit -> Effect Unit)
-- | Given a router, handle unhandled exceptions it raises by
-- | responding with 500 Internal Server Error.
onError500 :: (Request -> ResponseM) -> Request -> ResponseM
onError500 :: forall route. (Request route -> ResponseM) -> Request route -> ResponseM
onError500 router request =
catchError (router request) \err -> do
liftEffect $ error $ message err
@ -41,21 +43,36 @@ onError500 router request =
-- | request, extracts the `Response` from the `ResponseM`, and sends the
-- | `Response` to the HTTP `Response`.
handleRequest ::
(Request -> ResponseM) ->
forall route.
{ route :: RD.RouteDuplex' route
, router :: Request route -> ResponseM
, notFoundHandler :: Request Unit -> ResponseM
} ->
HTTP.Request ->
HTTP.Response ->
Effect Unit
handleRequest router request httpresponse =
void $ runAff (\_ -> pure unit) $ fromHTTPRequest request
>>= onError500 router
handleRequest { route, router, notFoundHandler } request httpresponse =
void $ runAff (\_ -> pure unit) $ fromHTTPRequest route request
>>= (notFoundHandler ||| onError500 router)
>>= send 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 HTTPure server without SSL.
serve' :: ListenOptions -> (Request -> ResponseM) -> Effect Unit -> ServerM
serve' options router onStarted = do
server <- HTTP.createServer (handleRequest router)
serve' ::
forall route.
ListenOptions ->
{ route :: RD.RouteDuplex' route
, router :: Request route -> ResponseM
, notFoundHandler :: Maybe (Request Unit -> ResponseM)
} ->
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
@ -63,16 +80,18 @@ serve' options router onStarted = do
-- | object, a function mapping `Request` to `ResponseM`, and a `ServerM`
-- | containing effects to run on boot, creates and runs a HTTPure server with
-- | SSL.
serveSecure' ::
Options SSLOptions ->
ListenOptions ->
(Request -> ResponseM) ->
Effect Unit ->
ServerM
serveSecure' sslOptions options router onStarted = do
server <- HTTPS.createServer sslOptions (handleRequest router)
listen server options onStarted
pure $ close server
-- serveSecure' ::
-- forall route.
-- Options SSLOptions ->
-- ListenOptions ->
-- RD.RouteDuplex' route ->
-- (Request route -> ResponseM) ->
-- Effect Unit ->
-- ServerM
-- serveSecure' sslOptions options route router onStarted = do
-- server <- HTTPS.createServer sslOptions (handleRequest route router)
-- listen server options onStarted
-- pure $ close server
-- | Given a port number, return a `HTTP.ListenOptions` `Record`.
listenOptions :: Int -> ListenOptions
@ -87,7 +106,15 @@ listenOptions port =
-- | `ResponseM`, and a `ServerM` containing effects to run after the server has
-- | booted (usually logging). Returns an `ServerM` containing the server's
-- | effects.
serve :: Int -> (Request -> ResponseM) -> Effect Unit -> ServerM
serve ::
forall route.
Int ->
{ route :: RD.RouteDuplex' route
, router :: Request route -> ResponseM
, notFoundHandler :: Maybe (Request Unit -> ResponseM)
} ->
Effect Unit ->
ServerM
serve = serve' <<< listenOptions
-- | Create and start an SSL server. This method is the same as `serve`, but
@ -97,15 +124,17 @@ serve = serve' <<< listenOptions
-- | 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 ::
Int ->
String ->
String ->
(Request -> ResponseM) ->
Effect Unit ->
ServerM
serveSecure port certFile keyFile router onStarted = do
cert' <- readTextFile UTF8 certFile
key' <- readTextFile UTF8 keyFile
let sslOpts = key := keyString key' <> cert := certString cert'
serveSecure' sslOpts (listenOptions port) router onStarted
-- serveSecure ::
-- forall route.
-- Int ->
-- String ->
-- String ->
-- RD.RouteDuplex' route ->
-- (Request route -> ResponseM) ->
-- Effect Unit ->
-- ServerM
-- serveSecure port certFile keyFile route router onStarted = do
-- cert' <- readTextFile UTF8 certFile
-- key' <- readTextFile UTF8 keyFile
-- let sslOpts = key := keyString key' <> cert := certString cert'
-- serveSecure' sslOpts (listenOptions port) route router onStarted

39
test/Test/HTTPure/ServerSpec.purs
View File

@ -3,36 +3,51 @@ module Test.HTTPure.ServerSpec where
import Prelude
import Control.Monad.Except (throwError)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(Nothing))
import Data.Options ((:=))
import Data.String (joinWith)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Foreign.Object (empty)
import HTTPure.Request (Request)
import HTTPure.Response (ResponseM, ok)
import HTTPure.Response (ResponseM, notFound, ok)
import HTTPure.Server (serve, serve', serveSecure, serveSecure')
import Node.Encoding (Encoding(UTF8))
import Node.FS.Sync (readTextFile)
import Node.HTTP.Secure (cert, certString, key, keyString)
import Test.HTTPure.TestHelpers (Test, get, get', getStatus, (?=))
import Node.HTTP.Secure (key, keyString, cert, certString)
import Routing.Duplex (RouteDuplex')
import Routing.Duplex as RD
import Routing.Duplex.Generic as G
import Routing.Duplex.Generic as RG
import Test.HTTPure.TestHelpers (Test, (?=), get, get', getStatus)
import Test.Spec (describe, it)
import Test.Spec.Assertions (expectError)
mockRouter :: Request -> ResponseM
mockRouter { path } = ok $ "/" <> joinWith "/" path
data Route = Test
derive instance Generic Route _
route :: RouteDuplex' Route
route = RD.root $ G.sum
{ "Test": RD.path "test" RG.noArgs
}
mockRouter :: Request Route -> ResponseM
mockRouter { route: Right Test } = ok $ RD.print route Test
mockRouter { route } = notFound
serveSpec :: Test
serveSpec =
describe "serve" do
it "boots a server on the given port" do
close <- liftEffect $ serve 8080 mockRouter $ pure unit
close <- liftEffect $ serve 8080 route mockRouter $ pure unit
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 router $ pure unit
close <- liftEffect $ serve 8080 route router $ pure unit
status <- getStatus 8080 empty "/"
liftEffect $ close $ pure unit
status ?= 500
@ -44,7 +59,7 @@ serve'Spec =
let options = { hostname: "localhost", port: 8080, backlog: Nothing }
close <-
liftEffect
$ serve' options mockRouter
$ serve' options route mockRouter
$ pure unit
out <- get 8080 empty "/test"
liftEffect $ close $ pure unit
@ -57,7 +72,7 @@ serveSecureSpec =
it "boots a server on the given port" do
close <-
liftEffect
$ serveSecure 8080 "./test/Mocks/Certificate.cer" "./test/Mocks/Key.key" mockRouter
$ serveSecure 8080 "./test/Mocks/Certificate.cer" "./test/Mocks/Key.key" route mockRouter
$ pure unit
out <- get' 8080 empty "/test"
liftEffect $ close $ pure unit
@ -65,7 +80,7 @@ serveSecureSpec =
describe "with invalid key and cert files" do
it "throws" do
expectError $ liftEffect
$ serveSecure 8080 "" "" mockRouter
$ serveSecure 8080 "" "" route mockRouter
$ pure unit
serveSecure'Spec :: Test
@ -82,7 +97,7 @@ serveSecure'Spec =
sslOpts <- liftEffect $ sslOptions
close <-
liftEffect
$ serveSecure' sslOpts options mockRouter
$ serveSecure' sslOpts options route mockRouter
$ pure unit
out <- get' 8080 empty "/test"
liftEffect $ close $ pure unit