Cleanup and export everything necessary

src/HTTPure.purs

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

src/HTTPurple/Middleware.purs

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

src/HTTPurple/NodeMiddleware.purs

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

src/HTTPurple/Request.purs

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

src/HTTPurple/Server.purs

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