First working example of routing duplex

Readme.md

@@ -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)
+[![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/cprussin/purescript-httpure.svg)](https://github.com/cprussin/purescript-httpure/releases)
+[![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)

src/HTTPure.purs

@@ -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
+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')
-  ( Response
+import HTTPure.Server (ServerM, serve, serve')
-  , 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.Status (Status)

src/HTTPure/Request.purs

@@ -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 :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route))
-fromHTTPRequest request = do
+fromHTTPRequest route request = do
   body <- liftEffect $ Body.read request
-  pure
+  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)
 

src/HTTPure/Routes.purs

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

src/HTTPure/Server.purs

@@ -2,26 +2,28 @@ module HTTPure.Server
   ( ServerM
   , serve
   , serve'
-  , serveSecure
+  -- , serveSecure
-  , serveSecure'
+  -- , serveSecure'
   ) where
 
 import Prelude
 
-import Data.Maybe (Maybe(Nothing))
+import Data.Maybe (Maybe(Nothing), maybe)
-import Data.Options (Options, (:=))
+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 =
+handleRequest { route, router, notFoundHandler } request httpresponse =
-  void $ runAff (\_ -> pure unit) $ fromHTTPRequest request
+  void $ runAff (\_ -> pure unit) $ fromHTTPRequest route request
-    >>= onError500 router
+    >>= (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' ::
-serve' options router onStarted = do
+  forall route.
-  server <- HTTP.createServer (handleRequest router)
+  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' ::
+-- serveSecure' ::
-  Options SSLOptions ->
+--   forall route.
-  ListenOptions ->
+--   Options SSLOptions ->
-  (Request -> ResponseM) ->
+--   ListenOptions ->
-  Effect Unit ->
+--   RD.RouteDuplex' route ->
-  ServerM
+--   (Request route -> ResponseM) ->
-serveSecure' sslOptions options router onStarted = do
+--   Effect Unit ->
-  server <- HTTPS.createServer sslOptions (handleRequest router)
+--   ServerM
-  listen server options onStarted
+-- serveSecure' sslOptions options route router onStarted = do
-  pure $ close server
+--   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 ::
+-- serveSecure ::
-  Int ->
+--   forall route.
-  String ->
+--   Int ->
-  String ->
+--   String ->
-  (Request -> ResponseM) ->
+--   String ->
-  Effect Unit ->
+--   RD.RouteDuplex' route ->
-  ServerM
+--   (Request route -> ResponseM) ->
-serveSecure port certFile keyFile router onStarted = do
+--   Effect Unit ->
-  cert' <- readTextFile UTF8 certFile
+--   ServerM
-  key' <- readTextFile UTF8 keyFile
+-- serveSecure port certFile keyFile route router onStarted = do
-  let sslOpts = key := keyString key' <> cert := certString cert'
+--   cert' <- readTextFile UTF8 certFile
-  serveSecure' sslOpts (listenOptions port) router onStarted
+--   key' <- readTextFile UTF8 keyFile
+--   let sslOpts = key := keyString key' <> cert := certString cert'
+--   serveSecure' sslOpts (listenOptions port) route router onStarted

test/Test/HTTPure/ServerSpec.purs

@@ -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 Node.HTTP.Secure (key, keyString, cert, certString)
-import Test.HTTPure.TestHelpers (Test, get, get', getStatus, (?=))
+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
+data Route = Test
-mockRouter { path } = ok $ "/" <> joinWith "/" path
+
+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