diff --git a/packages.dhall b/packages.dhall index 5f7bc82..933feb7 100644 --- a/packages.dhall +++ b/packages.dhall @@ -1,5 +1,6 @@ let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.15.0-20220525/packages.dhall - sha256:5facfdf9c35801a0e6a41b08b4293f947743007a9224a2a3d7694d87a44a7f28 + https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220805/packages.dhall + sha256:c80e241af3ba62fc42284b9bc26b4c9bd4525eebe4ab0e9198c9bbeac102f656 in upstream + with untagged-union = ../purescript-untagged-union/spago.dhall as Location diff --git a/spago.dhall b/spago.dhall index eb1f42c..c451861 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,12 +5,17 @@ , "bifunctors" , "console" , "control" + , "debug" , "effect" , "either" + , "exceptions" , "foldable-traversable" , "foreign-object" + , "functions" , "js-uri" , "justifill" + , "lists" + , "literals" , "maybe" , "newtype" , "node-buffer" @@ -26,10 +31,14 @@ , "record" , "refs" , "routing-duplex" + , "safe-coerce" , "strings" , "transformers" , "tuples" , "type-equality" + , "typelevel-prelude" + , "unsafe-coerce" + , "untagged-union" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs" ] diff --git a/src/HTTPurple/NodeMiddleware.purs b/src/HTTPurple/NodeMiddleware.purs new file mode 100644 index 0000000..f10fdf2 --- /dev/null +++ b/src/HTTPurple/NodeMiddleware.purs @@ -0,0 +1,83 @@ +module HTTPurple.NodeMiddleware where + +import Prelude + +import Control.Monad.Cont (ContT(..)) +import Data.Generic.Rep (class Generic) +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) +import Effect (Effect) +import Effect.Exception (Error) +import Effect.Ref as Ref +import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, runEffectFn1, runEffectFn3) +import Literals.Undefined (Undefined, undefined) +import Node.HTTP as HTTP +import Prim.Row (class Union) +import Untagged.Union (type (|+|), UndefinedOr, asOneOf, uorToMaybe) + +newtype NodeMiddleware :: forall k. k -> Type +newtype NodeMiddleware extended = + NodeMiddleware (EffectFn3 HTTP.Request HTTP.Response (EffectFn1 (UndefinedOr Error) Unit) (Effect Unit)) + +derive instance Newtype (NodeMiddleware extended) _ + +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 + +usingContinuation :: + forall input thru tmp tmp2 output. + Union input thru tmp => + Union tmp tmp2 output => + NodeMiddleware thru -> + MiddlewareResult input -> + (MiddlewareResult input -> Effect (MiddlewareResult output)) -> + Effect (MiddlewareResult output) +usingContinuation (NodeMiddleware middleware) reqResp@(MiddlewareResult { request, response }) nextHandler = do + middlewareResult <- callMiddleware reqResp + case middlewareResult of + res@(ProcessingSucceeded) -> + nextHandler (MiddlewareResult { request, response, middlewareResult: res }) + res@(ProcessingFailed _) -> pure (MiddlewareResult { request, response, middlewareResult: res }) + res@(NotCalled) -> pure (MiddlewareResult { request, response, middlewareResult: res }) + where + callMiddleware :: MiddlewareResult input -> Effect (NextInvocation) + callMiddleware (MiddlewareResult { request: rIn, response: rOut }) = do + ref <- Ref.new NotCalled + let + next :: EffectFn1 (UndefinedOr Error) Unit + next = mkEffectFn1 \error -> case uorToMaybe error of + Just err -> Ref.write (ProcessingFailed err) ref + Nothing -> Ref.write (ProcessingSucceeded) ref + _ <- runEffectFn3 middleware rIn rOut next + Ref.read ref + +class UsingMiddleware :: Row Type -> Row Type -> Row Type -> Constraint +class UsingMiddleware input thru output | input thru -> output where + usingMiddleware :: + NodeMiddleware thru -> + MiddlewareResult input -> + ContT (MiddlewareResult output) Effect (MiddlewareResult input) + +instance (Union input thru tmp, Union tmp tmp2 output) => UsingMiddleware input thru output where + usingMiddleware nodeMiddleware reqResp = ContT $ usingContinuation nodeMiddleware reqResp + +type NextHandlerArg = Undefined |+| Error + +dontCallNext :: forall (m :: Type -> Type). Applicative m => m Unit +dontCallNext = pure unit + +callNext :: EffectFn1 NextHandlerArg Unit -> Effect Unit +callNext next = runEffectFn1 next (asOneOf $ undefined) + +callNextWithError :: EffectFn1 NextHandlerArg Unit -> Error -> Effect Unit +callNextWithError next err = runEffectFn1 next (asOneOf err) diff --git a/src/HTTPurple/Record/Extra.js b/src/HTTPurple/Record/Extra.js new file mode 100644 index 0000000..c7506d8 --- /dev/null +++ b/src/HTTPurple/Record/Extra.js @@ -0,0 +1,8 @@ + +export const pickFn = function(ks, r) { + var copy = {}; + for(var i = 0; i < ks.length; i++) { + copy[ks[i]] = r[ks[i]]; + } + return copy; + }; diff --git a/src/HTTPurple/Record/Extra.purs b/src/HTTPurple/Record/Extra.purs new file mode 100644 index 0000000..fca3979 --- /dev/null +++ b/src/HTTPurple/Record/Extra.purs @@ -0,0 +1,49 @@ +module HTTPurple.Record.Extra where + +import Prelude + +import Data.Array (fromFoldable) +import Data.Function.Uncurried (Fn2, runFn2) +import Data.List (List, (:)) +import Data.Symbol (class IsSymbol, reflectSymbol) +import Prim.Row as Row +import Prim.RowList as RL +import Type.Proxy (Proxy(..)) + +class Keys (xs :: RL.RowList Type) where + keysImpl :: Proxy xs -> List String + +instance Keys RL.Nil where + keysImpl _ = mempty + +instance + ( IsSymbol name + , Keys tail + ) => + Keys (RL.Cons name ty tail) where + keysImpl _ = first : rest + where + first = reflectSymbol (Proxy :: _ name) + rest = keysImpl (Proxy :: _ tail) + +keys :: + forall g row rl. + RL.RowToList row rl => + Keys rl => + g row -- this will work for any type with the row as a param! + -> + List String +keys _ = keysImpl (Proxy :: _ rl) + +foreign import pickFn :: forall r1 r2. Fn2 (Array String) (Record r1) (Record r2) + +pick :: + forall a r b l. + Row.Union b r a => + RL.RowToList b l => + Keys l => + Record a -> + Record b +pick = runFn2 pickFn ks + where + ks = fromFoldable $ keys (Proxy :: _ b) diff --git a/src/HTTPurple/Request.purs b/src/HTTPurple/Request.purs index bee297b..e78589b 100644 --- a/src/HTTPurple/Request.purs +++ b/src/HTTPurple/Request.purs @@ -1,16 +1,22 @@ module HTTPurple.Request - ( Request + ( ExtRequest(..) + , Request + , RequestR , fromHTTPRequest + , fromHTTPRequestExt + , fromHTTPRequestUnit , fullPath ) where import Prelude -import Data.Bifunctor (bimap) +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.Class (liftEffect) +import Effect.Class (class MonadEffect, liftEffect) import Foreign.Object (isEmpty, toArrayWithKey) import HTTPurple.Body (RequestBody) import HTTPurple.Body (read) as Body @@ -22,17 +28,22 @@ import HTTPurple.Path (Path) import HTTPurple.Path (read) as Path import HTTPurple.Query (Query) import HTTPurple.Query (read) as Query +import HTTPurple.Record.Extra (pick) +import HTTPurple.Record.Extra as Extra import HTTPurple.Utils (encodeURIComponent) import HTTPurple.Version (Version) import HTTPurple.Version (read) as Version import Node.HTTP (Request) as HTTP import Node.HTTP (requestURL) +import Prim.Row (class Nub, class Union) +import Prim.RowList (class RowToList) +import Record (merge) import Routing.Duplex as RD +import Type.Prelude (Proxy) +import Unsafe.Coerce (unsafeCoerce) --- | The `Request` type is a `Record` type that includes fields for accessing --- | the different parts of the HTTP request. -type Request route = - { method :: Method +type RequestR route r = + ( method :: Method , path :: Path , query :: Query , route :: route @@ -40,36 +51,71 @@ type Request route = , body :: RequestBody , httpVersion :: Version , url :: String - } + | r + ) + +-- | The `Request` type is a `Record` type that includes fields for accessing +-- | the different parts of the HTTP request. +type Request route = { | RequestR route () } + +newtype ExtRequest :: Type -> Row Type -> Type +newtype ExtRequest route ext = ExtRequest { | RequestR route ext } + +derive instance Newtype (ExtRequest route ext) _ -- | 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 :: forall route. Request route -> String -fullPath request = "/" <> path <> questionMark <> queryParams +fullPath :: forall r. { path :: Path, query :: Query | r } -> String +fullPath { path: p, query } = "/" <> path <> questionMark <> queryParams where - path = joinWith "/" request.path - questionMark = if isEmpty request.query then "" else "?" + path = joinWith "/" p + questionMark = if isEmpty query then "" else "?" queryParams = joinWith "&" queryParamsArr - queryParamsArr = toArrayWithKey stringifyQueryParam request.query + queryParamsArr = toArrayWithKey stringifyQueryParam query stringifyQueryParam key value = encodeURIComponent key <> "=" <> encodeURIComponent value +mkRequest :: forall route m. MonadEffect m => HTTP.Request -> route -> m (Request route) +mkRequest request route = do + body <- liftEffect $ Body.read request + pure + { method: Method.read request + , path: Path.read request + , query: Query.read request + , route: route + , headers: Headers.read request + , body + , httpVersion: Version.read request + , url: requestURL request + } + -- | Given an HTTP `Request` object, this method will convert it to an HTTPurple -- | `Request` object. fromHTTPRequest :: forall route. RD.RouteDuplex' route -> HTTP.Request -> Aff (Either (Request Unit) (Request route)) fromHTTPRequest route request = do - body <- liftEffect $ Body.read 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) + RD.parse route (requestURL request) # + bitraverse (const $ mkRequest request unit) (mkRequest request) +fromHTTPRequestUnit :: HTTP.Request -> Aff (Request Unit) +fromHTTPRequestUnit request = mkRequest request unit + +fromHTTPRequestExt :: + forall ctx ctxRL thru route. + Union ctx thru ctx => + Nub (RequestR route ctx) (RequestR route ctx) => + RowToList ctx ctxRL => + Extra.Keys ctxRL => + RD.RouteDuplex' route -> + Proxy ctx -> + HTTP.Request -> + Aff (Either (Request Unit) (ExtRequest route ctx)) +fromHTTPRequestExt route _ nodeRequest = do + let + extension :: Record ctx + extension = pick (unsafeCoerce nodeRequest :: Record ctx) + + addExtension :: Request route -> ExtRequest route ctx + addExtension = flip merge extension >>> ExtRequest + + request <- fromHTTPRequest route nodeRequest + pure $ rmap addExtension request diff --git a/src/HTTPurple/Server.purs b/src/HTTPurple/Server.purs index c5bc262..0108b3d 100644 --- a/src/HTTPurple/Server.purs +++ b/src/HTTPurple/Server.purs @@ -5,22 +5,29 @@ module HTTPurple.Server , RoutingSettings , RoutingSettingsR , ServerM + , defaultMiddlewareErrorHandler , serve + , serveWithMiddleware ) where import Prelude +import Control.Monad.Cont (ContT, runContT) import Data.Maybe (Maybe(..), fromMaybe) import Data.Options ((:=)) import Data.Posix.Signal (Signal(..)) import Data.Profunctor.Choice ((|||)) +import Debug (spy) import Effect (Effect) -import Effect.Aff (catchError, message, runAff) +import Effect.Aff (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 Effect.Exception (Error) +import HTTPurple.NodeMiddleware (MiddlewareResult(..), NextInvocation(..)) +import HTTPurple.Record.Extra as Extra +import HTTPurple.Request (ExtRequest, Request, RequestR, fromHTTPRequest, fromHTTPRequestExt, fromHTTPRequestUnit) +import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, send) import Justifill (justifill) import Justifill.Fillable (class FillableFields) import Justifill.Justifiable (class JustifiableFields) @@ -31,9 +38,13 @@ 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.Row (class Nub, class Union) import Prim.RowList (class RowToList) +import Record (merge) import Routing.Duplex as RD +import Safe.Coerce (coerce) +import Type.Prelude (Proxy(..)) +import Type.Row (type (+)) -- | The `ServerM` is just an `Effect` containing a callback to close the -- | server. This type is the return type of the HTTPurple serve and related @@ -62,14 +73,32 @@ type RoutingSettingsR route = type RoutingSettings route = { | RoutingSettingsR route } +type ExtRoutingSettingsR route output r = + ( route :: RD.RouteDuplex' route + , router :: ExtRequest route output -> ResponseM + | r + ) + +type MiddlewareSettingsR input output = + ( middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input) + , middlewareErrorHandler :: Error -> Request Unit -> Aff Response + ) + +type ExtRoutingSettings route input output = { | ExtRoutingSettingsR route output + MiddlewareSettingsR input output } + -- | Given a router, handle unhandled exceptions it raises by -- | responding with 500 Internal Server Error. -onError500 :: forall route. (Request route -> ResponseM) -> Request route -> ResponseM +onError500 :: forall request. (request -> ResponseM) -> request -> ResponseM onError500 router request = catchError (router request) \err -> do liftEffect $ error $ message err internalServerError "Internal server error" +defaultMiddlewareErrorHandler :: Error -> Request Unit -> Aff Response +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 @@ -88,6 +117,62 @@ handleRequest { route, router, notFoundHandler } request httpresponse = >>= (notFoundHandler ||| onError500 router) >>= send httpresponse +handleRequestUnit :: + (Request Unit -> ResponseM) -> + HTTP.Request -> + HTTP.Response -> + Effect Unit +handleRequestUnit router request httpresponse = + void $ runAff (\_ -> pure unit) $ fromHTTPRequestUnit request + >>= (onError500 router) + >>= send httpresponse + +handleExtRequest :: + forall ctx ctxRL thru route. + Union ctx thru ctx => + RowToList ctx ctxRL => + Extra.Keys ctxRL => + Nub (RequestR route ctx) (RequestR route ctx) => + { route :: RD.RouteDuplex' route + , router :: ExtRequest route ctx -> ResponseM + , notFoundHandler :: Request Unit -> ResponseM + } -> + HTTP.Request -> + HTTP.Response -> + Aff Unit +handleExtRequest { route, router, notFoundHandler } req resp = do + httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req + httpurpleResp <- (notFoundHandler ||| onError500 router) httpurpleReq + send resp httpurpleResp + +handleExtRequestWithMiddleware :: + forall input output outputRL thru route. + Union output thru output => + RowToList output outputRL => + Extra.Keys outputRL => + Nub (RequestR route output) (RequestR route output) => + { route :: RD.RouteDuplex' route + , middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input) + , middlewareErrorHandler :: Error -> Request Unit -> Aff Response + , router :: ExtRequest route output -> ResponseM + , notFoundHandler :: Request Unit -> ResponseM + } -> + HTTP.Request -> + HTTP.Response -> + Effect Unit +handleExtRequestWithMiddleware { route, middleware, middlewareErrorHandler, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ 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 { request, response, middlewareResult: ProcessingFailed error }) = + liftEffect $ handleRequestUnit (middlewareErrorHandler 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 = const notFound @@ -147,12 +232,66 @@ serve inputOptions { route, router } = do 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 "Aye, stopping service now. Goodbye!" - onSignal SIGTERM $ closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye..." - pure closingHandler + registerClosingHandler filledOptions.closingHandler closingHandler + +serveWithMiddleware :: + 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 +serveWithMiddleware inputOptions settings = do + let + filledOptions :: ListenOptions + filledOptions = justifillListenOptions 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 :: RD.RouteDuplex' route + , middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input) + , middlewareErrorHandler :: Error -> Request Unit -> Aff Response + , router :: ExtRequest route output -> ResponseM + , notFoundHandler :: Request Unit -> ResponseM + } + routingSettings = merge settings { 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 (handleExtRequestWithMiddleware routingSettings) + Nothing -> HTTP.createServer (handleExtRequestWithMiddleware routingSettings) + listen server options onStarted + let closingHandler = close server + registerClosingHandler filledOptions.closingHandler closingHandler + +registerClosingHandler :: Maybe ClosingHandler -> (Effect Unit -> Effect Unit) -> ServerM +registerClosingHandler (Just NoClosingHandler) closingHandler = pure closingHandler +registerClosingHandler _ closingHandler = do + onSignal SIGINT $ closingHandler $ log "Aye, stopping service now. Goodbye!" + onSignal SIGTERM $ closingHandler $ log "Arrgghh I got stabbed in the back 🗡 ... good...bye..." + pure closingHandler defaultHostname :: String defaultHostname = "0.0.0.0" diff --git a/src/Middleware.purs b/src/Middleware.purs new file mode 100644 index 0000000..0f44681 --- /dev/null +++ b/src/Middleware.purs @@ -0,0 +1,66 @@ +module Middleware + ( MiddlewareProcessing(..) + , NodeMiddleware + , using + , usingContinuation + ) where + +import Prelude + +import Control.Monad.Cont (ContT(..)) +import Data.Tuple.Nested (type (/\), (/\)) +import Debug (spy) +import Effect (Effect) +import Effect.Aff (launchAff_) +import Effect.Aff.Class (class MonadAff) +import Effect.Ref as Ref +import HTTPurple.Request (Request, fromHTTPRequest) +import HTTPurple.Response (Response, send) +import Node.HTTP as HTTP +import Routing.Duplex (RouteDuplex') + +type NodeMiddleware = HTTP.Request -> HTTP.Response -> Effect Unit -> Effect Unit + +data MiddlewareProcessing = NotStarted | ProcessingFailed | ProcessingSucceeded (HTTP.Request /\ HTTP.Response) + +usingContinuation :: + NodeMiddleware -> + (HTTP.Request /\ HTTP.Response) -> + ((HTTP.Request /\ HTTP.Response) -> Effect MiddlewareProcessing) -> + Effect MiddlewareProcessing +usingContinuation middleware reqResp nextHandler = do + middlewareResult <- callMiddleware reqResp + case middlewareResult of + res@(ProcessingSucceeded newReqResp) -> let _ = spy "Next called" res in nextHandler newReqResp + res -> let _ = spy "Next not called" res in pure res + where + callMiddleware :: HTTP.Request /\ HTTP.Response -> Effect (MiddlewareProcessing) + callMiddleware (req /\ resp) = do + ref <- Ref.new NotStarted + let + next :: Effect Unit + next = Ref.write (ProcessingSucceeded reqResp) ref + middleware req resp next + value <- Ref.read ref + pure value + +using :: + (HTTP.Request -> HTTP.Response -> Effect Unit -> Effect Unit) -> + HTTP.Request /\ HTTP.Response -> + ContT MiddlewareProcessing Effect (HTTP.Request /\ HTTP.Response) +using nodeMiddleware reqResp = ContT $ usingContinuation nodeMiddleware reqResp + +type Handler route m = Request route -> m Response + +-- runHandler :: +-- forall route m. +-- MonadAff m => +-- RouteDuplex' route -> +-- Handler route m -> +-- HTTP.Request -> +-- HTTP.Response -> +-- Effect Unit +-- runHandler rd handler req resp = launchAff_ do +-- httpurpleReq <- fromHTTPRequest rd req +-- httpurpleResp <- handler httpurpleReq +-- send resp httpurpleResp