diff --git a/examples/transformer/Main.purs b/examples/transformer/Main.purs new file mode 100644 index 0000000..6b2a924 --- /dev/null +++ b/examples/transformer/Main.purs @@ -0,0 +1,59 @@ +module Payload.Examples.Transformer.Main where + +import Prelude + +import Control.Monad.Reader.Trans (ReaderT, ask, asks, runReaderT) +import Data.Either (Either, note) +import Data.Foldable (find) +import Effect (Effect) +import Effect.Aff (Aff, launchAff_) +import Effect.Aff.Class (liftAff) +import Node.HTTP as HTTP +import Payload.Headers as Headers +import Payload.ResponseTypes (Response) +import Payload.Server as Payload +import Payload.Server.Guards as Guards +import Payload.Server.Response as Resp +import Payload.Spec (type (:), Nil, GET, Guards, Spec(Spec)) + +type Env = + { adminKey :: String + , dbConnectionString :: String + } + +spec :: Spec + { guards :: + { adminKeyMatch :: Unit + } + , routes :: + { env :: GET "/env" { guards :: Guards ("adminKeyMatch" : Nil), response :: Env } + } + } +spec = Spec + +guards :: + { adminKeyMatch :: + HTTP.Request -> ReaderT Env Aff (Either (Response String) Unit) + } +guards = + { adminKeyMatch: \request -> do + expected <- asks _.adminKey + headers <- liftAff $ Guards.headers request + let provided = find (\x -> x == expected) $ Headers.lookup "x-admin-key" headers + pure $ void $ note (Resp.unauthorized $ "\"x-admin-key\" header must match configured secret key (\"" <> expected <> "\")") provided + } + +handlers :: + { env :: + { guards :: { adminKeyMatch :: Unit } } -> ReaderT Env Aff Env + } +handlers = { env: const ask } + +main :: Effect Unit +main = + launchAff_ $ + Payload.startGuarded' + (flip runReaderT { adminKey: "secret", dbConnectionString: "postgresql://postgres@localhost/postgres" }) + Payload.defaultOpts + spec + { guards, handlers } diff --git a/examples/transformer/Test.purs b/examples/transformer/Test.purs new file mode 100644 index 0000000..a553c82 --- /dev/null +++ b/examples/transformer/Test.purs @@ -0,0 +1,44 @@ +module Payload.Examples.Transformer.Test where + +import Prelude + +import Control.Monad.Reader.Trans (runReaderT) +import Payload.Examples.Transformer.Main (guards, handlers, spec) +import Payload.Headers (empty, set) as Headers +import Payload.Test.Helpers (respMatches, withServer') +import Payload.Test.Helpers as Helpers +import Simple.JSON (writeJSON) +import Test.Unit (TestSuite, suite, test) +import Test.Unit.Assert as Assert + +env :: { adminKey :: String, dbConnectionString :: String } +env = + { adminKey: "foo" + , dbConnectionString: "bar" + } + +tests :: TestSuite +tests = do + let withApi = withServer' (flip runReaderT env) spec { guards, handlers } + suite "Transformer" do + let host = "http://localhost:3000" + path = "/env" + test ("GET " <> path <> " with admin key succeeds") $ withApi do + res <- Helpers.get_ + host + path + $ Headers.empty # Headers.set "x-admin-key" "foo" + respMatches + { status: 200 + , body: writeJSON env + } + res + test ("GET " <> path <> " with invalid x-admin-key header fails with 401 Unauthorized") $ withApi do + res <- Helpers.get_ + host + path + $ Headers.empty # Headers.set "x-admin-key" "xx" + Assert.equal 401 res.status + test ("GET " <> path <> " without x-admin-key header fails with 401 Unauthorized") $ withApi do + res <- (Helpers.request host).get path + Assert.equal 401 res.status diff --git a/src/Payload/ResponseTypes.purs b/src/Payload/ResponseTypes.purs index 436a0a3..155129e 100644 --- a/src/Payload/ResponseTypes.purs +++ b/src/Payload/ResponseTypes.purs @@ -58,5 +58,5 @@ instance showResponseBody :: Show ResponseBody where show (StreamBody _) = "StreamBody" -- | Internally handlers and guards all de-sugar into this type. -type Result a = ExceptT Failure Aff a +type Result m = ExceptT Failure m diff --git a/src/Payload/Server.purs b/src/Payload/Server.purs index ada945e..e702437 100644 --- a/src/Payload/Server.purs +++ b/src/Payload/Server.purs @@ -4,6 +4,7 @@ module Payload.Server , start_ , startGuarded , startGuarded_ + , startGuarded' , Options , defaultOpts , LogLevel(..) @@ -23,7 +24,7 @@ import Data.String as String import Effect (Effect) import Effect.Aff (Aff) import Effect.Aff as Aff -import Effect.Class (liftEffect) +import Effect.Class (class MonadEffect, liftEffect) import Effect.Console (log) import Effect.Exception (Error) import Node.HTTP as HTTP @@ -88,7 +89,7 @@ type Logger = -- | Start server with default options, ignoring unexpected startup errors. launch :: forall routesSpec handlers - . Routable routesSpec {} handlers {} + . Routable routesSpec {} handlers {} Aff => Spec routesSpec -> handlers -> Effect Unit @@ -97,7 +98,7 @@ launch routeSpec handlers = Aff.launchAff_ (start_ routeSpec handlers) -- | Start server with default options and given route spec and handlers (no guards). start_ :: forall routesSpec handlers - . Routable routesSpec {} handlers {} + . Routable routesSpec {} handlers {} Aff => Spec routesSpec -> handlers -> Aff (Either String Server) @@ -106,7 +107,7 @@ start_ = start defaultOpts -- | Start server with given routes and handlers (no guards). start :: forall routesSpec handlers - . Routable routesSpec {} handlers {} + . Routable routesSpec {} handlers {} Aff => Options -> Spec routesSpec -> handlers @@ -118,7 +119,7 @@ start opts routeSpec handlers = startGuarded opts api { handlers, guards: {} } -- | Start server with default options and given spec, handlers, and guards. startGuarded_ :: forall routesSpec guardsSpec handlers guards - . Routable routesSpec guardsSpec handlers guards + . Routable routesSpec guardsSpec handlers guards Aff => Spec { routes :: routesSpec, guards :: guardsSpec } -> { handlers :: handlers, guards :: guards } -> Aff (Either String Server) @@ -127,25 +128,37 @@ startGuarded_ = startGuarded defaultOpts -- | Start server with given spec, handlers, and guards. startGuarded :: forall routesSpec guardsSpec handlers guards - . Routable routesSpec guardsSpec handlers guards + . Routable routesSpec guardsSpec handlers guards Aff => Options -> Spec { guards :: guardsSpec, routes :: routesSpec } -> { handlers :: handlers, guards :: guards } -> Aff (Either String Server) -startGuarded opts apiSpec api = do +startGuarded = startGuarded' identity + +-- | Start server with given monad transformation, spec, handlers, and guards. +startGuarded' + :: forall routesSpec guardsSpec handlers guards m + . MonadEffect m + => Routable routesSpec guardsSpec handlers guards m + => (m ~> Aff) + -> Options + -> Spec { guards :: guardsSpec, routes :: routesSpec } + -> { handlers :: handlers, guards :: guards } + -> Aff (Either String Server) +startGuarded' runM opts apiSpec api = do let cfg = mkConfig opts case mkRouter apiSpec api of Right routerTrie -> do - server <- Server <$> (liftEffect $ HTTP.createServer (handleRequest cfg routerTrie)) + server <- Server <$> (liftEffect $ HTTP.createServer (handleRequest runM cfg routerTrie)) let httpOpts = Record.delete (Proxy :: Proxy "logLevel") opts listenResult <- listen cfg server httpOpts pure (const server <$> listenResult) Left err -> pure (Left err) -dumpRoutes :: Trie HandlerEntry -> Effect Unit +dumpRoutes :: forall m. Trie (HandlerEntry m) -> Effect Unit dumpRoutes = log <<< showRoutes -showRoutes :: Trie HandlerEntry -> String +showRoutes :: forall m. Trie (HandlerEntry m) -> String showRoutes routerTrie = Trie.dumpEntries (_.route <$> routerTrie) mkConfig :: Options -> Config @@ -166,29 +179,54 @@ mkLogger logLevel = { log: log_, logDebug, logError } logError | logLevel >= LogError = log logError = const $ pure unit -handleRequest :: Config -> Trie HandlerEntry -> HTTP.Request -> HTTP.Response -> Effect Unit -handleRequest cfg@{ logger } routerTrie req res = do +handleRequest + :: forall m + . MonadEffect m + => (m ~> Aff) + -> Config + -> Trie (HandlerEntry m) + -> HTTP.Request + -> HTTP.Response + -> Effect Unit +handleRequest runM cfg@{ logger } routerTrie req res = do let url = Url.parse (HTTP.requestURL req) logger.logDebug (HTTP.requestMethod req <> " " <> show (url.path)) case requestUrl req of - Right reqUrl -> runHandlers cfg routerTrie reqUrl req res + Right reqUrl -> runHandlers runM cfg routerTrie reqUrl req res Left err -> do writeResponse res (internalError $ StringBody $ "Path could not be decoded: " <> show err) -runHandlers :: Config -> Trie HandlerEntry -> RequestUrl - -> HTTP.Request -> HTTP.Response -> Effect Unit -runHandlers { logger } routerTrie reqUrl req res = do - let (matches :: List HandlerEntry) = Trie.lookup (reqUrl.method : reqUrl.path) routerTrie +runHandlers + :: forall m + . MonadEffect m + => (m ~> Aff) + -> Config + -> Trie (HandlerEntry m) + -> RequestUrl + -> HTTP.Request + -> HTTP.Response + -> Effect Unit +runHandlers runM { logger } routerTrie reqUrl req res = do + let (matches :: List (HandlerEntry m)) = Trie.lookup (reqUrl.method : reqUrl.path) routerTrie let matchesStr = String.joinWith "\n" (Array.fromFoldable $ (showRouteUrl <<< _.route) <$> matches) logger.logDebug $ showUrl reqUrl <> " -> " <> show (List.length matches) <> " matches:\n" <> matchesStr - Aff.launchAff_ $ do - outcome <- handleNext Nothing matches - case outcome of - (Forward msg) -> do - liftEffect $ writeResponse res (Response.notFound (StringBody "")) - _ -> pure unit + Aff.runAff_ + ( + case _ of + Left e -> liftEffect do + logger.logError $ show e + writeResponse res (internalError (StringBody "Internal error")) + _ -> + pure unit + ) + $ runM do + outcome <- handleNext Nothing matches + case outcome of + (Forward msg) -> do + liftEffect $ writeResponse res (Response.notFound (StringBody "")) + _ -> pure unit where - handleNext :: Maybe Outcome -> List HandlerEntry -> Aff Outcome + handleNext :: Maybe Outcome -> List (HandlerEntry m) -> m Outcome handleNext Nothing ({ handler } : rest) = do outcome <- handler reqUrl req res handleNext (Just outcome) rest @@ -203,7 +241,7 @@ runHandlers { logger } routerTrie reqUrl req res = do pure (Forward "No match could handle") handleNext _ Nil = pure (Forward "No match could handle") -showMatches :: List HandlerEntry -> String +showMatches :: forall m. List (HandlerEntry m) -> String showMatches matches = " " <> String.joinWith "\n " (Array.fromFoldable $ showMatch <$> matches) where showMatch = showRouteUrl <<< _.route diff --git a/src/Payload/Server/Guards.purs b/src/Payload/Server/Guards.purs index 1ed2d63..2db09c7 100644 --- a/src/Payload/Server/Guards.purs +++ b/src/Payload/Server/Guards.purs @@ -18,6 +18,7 @@ import Data.Map (Map) import Data.Symbol (class IsSymbol) import Data.Tuple (Tuple) import Effect.Aff (Aff) +import Effect.Aff.Class (class MonadAff) import Foreign.Object as Object import Node.HTTP as HTTP import Payload.Headers (Headers) @@ -38,7 +39,7 @@ import Type.Proxy (Proxy(..)) -- | Guards can also fail and return a response directly, by returning -- | Either. class ToGuardVal a b where - toGuardVal :: a -> Result b + toGuardVal :: forall m. MonadAff m => a -> Result m b instance toGuardValEitherFailureVal :: ToGuardVal (Either Failure a) a where @@ -76,35 +77,37 @@ rawRequest req = pure req cookies :: HTTP.Request -> Aff (Map String String) cookies req = pure (Cookies.requestCookies req) -type GuardFn a = HTTP.Request -> Aff a +type GuardFn m a = HTTP.Request -> m a class RunGuards (guardNames :: GuardList) (guardsSpec :: Row Type) (allGuards :: Row Type) (results :: Row Type) - (routeGuardSpec :: Row Type) | guardNames guardsSpec allGuards -> routeGuardSpec where - runGuards :: Guards guardNames + (routeGuardSpec :: Row Type) + m | guardNames guardsSpec allGuards -> routeGuardSpec where + runGuards :: Guards guardNames -> GuardTypes (Record guardsSpec) -> Record allGuards -> Record results -> HTTP.Request - -> Result (Record routeGuardSpec) + -> Result m (Record routeGuardSpec) -instance runGuardsNil :: RunGuards GNil guardsSpec allGuards routeGuardSpec routeGuardSpec where +instance runGuardsNil :: Monad m => RunGuards GNil guardsSpec allGuards routeGuardSpec routeGuardSpec m where runGuards _ _ allGuards results req = pure results instance runGuardsCons :: ( IsSymbol name , Row.Cons name guardVal guardsSpec' guardsSpec - , Row.Cons name (GuardFn guardRes) allGuards' allGuards + , Row.Cons name (GuardFn m guardRes) allGuards' allGuards , Row.Cons name guardVal results newResults , Row.Lacks name results , ToGuardVal guardRes guardVal - , RunGuards rest guardsSpec allGuards newResults routeGuardSpec - ) => RunGuards (GCons name rest) guardsSpec allGuards results routeGuardSpec where + , RunGuards rest guardsSpec allGuards newResults routeGuardSpec m + , MonadAff m + ) => RunGuards (GCons name rest) guardsSpec allGuards results routeGuardSpec m where runGuards _ _ allGuards results req = do - let (guardHandler :: GuardFn guardRes) = Record.get (Proxy :: Proxy name) (to allGuards) + let (guardHandler :: GuardFn m guardRes) = Record.get (Proxy :: Proxy name) (to allGuards) (guardHandlerResult :: guardRes) <- lift $ guardHandler req (guardResult :: guardVal) <- toGuardVal guardHandlerResult let newResults = Record.insert (Proxy :: Proxy name) guardResult results diff --git a/src/Payload/Server/Handleable.purs b/src/Payload/Server/Handleable.purs index a52a340..0fea0a2 100644 --- a/src/Payload/Server/Handleable.purs +++ b/src/Payload/Server/Handleable.purs @@ -15,6 +15,7 @@ import Data.Symbol (class IsSymbol) import Effect (Effect) import Effect.Aff (Aff) import Effect.Aff as Aff +import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Exception as Ex import Effect.Ref as Ref import Node.Encoding (Encoding(..)) @@ -38,7 +39,7 @@ import Prim.Symbol as Symbol import Type.Equality (class TypeEquals, to) import Type.Proxy (Proxy(..)) -type MethodHandler = RequestUrl -> HTTP.Request -> HTTP.Response -> Result RawResponse +type MethodHandler m = RequestUrl -> HTTP.Request -> HTTP.Response -> Result m RawResponse class Handleable route @@ -47,7 +48,8 @@ class Handleable (baseParams :: Row Type) (baseGuards :: GuardList) (guardsSpec :: Row Type) - guards | route -> handler where + guards + m | route -> handler where handle :: Proxy basePath -> Proxy (Record baseParams) -> Guards baseGuards @@ -58,7 +60,7 @@ class Handleable -> RequestUrl -> HTTP.Request -> HTTP.Response - -> Result RawResponse + -> Result m RawResponse instance handleablePostRoute :: ( TypeEquals (Record route) @@ -90,15 +92,17 @@ instance handleablePostRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "POST" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -145,15 +149,17 @@ instance handleableGetRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "GET" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -198,15 +204,17 @@ instance handleableHeadRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "HEAD" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -254,15 +262,17 @@ instance handleablePutRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "PUT" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -312,15 +322,17 @@ instance handleableDeleteRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "DELETE" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -367,15 +379,17 @@ instance handleableOptionsRoute :: , OmitEmpty payloadWithEmpty payload , GuardParsing.Append baseGuards guardNames fullGuards - , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec + , RunGuards fullGuards guardsSpec allGuards () routeGuardSpec m + , MonadAff m ) => Handleable (Route "OPTIONS" path (Record route)) - (Record payload -> Aff handlerRes) + (Record payload -> m handlerRes) basePath baseParams baseGuards guardsSpec - (Record allGuards) where + (Record allGuards) + m where handle _ _ _ _ route handler allGuards { method, path, query } req res = do guards <- runGuards (Guards :: _ fullGuards) (GuardTypes :: _ (Record guardsSpec)) allGuards {} req params <- withExceptT Forward $ except $ decodePath path @@ -393,18 +407,19 @@ instance handleableOptionsRoute :: decodeQuery :: String -> Either String (Record query) decodeQuery = PayloadQuery.decodeQuery (Proxy :: _ fullPath) (Proxy :: _ (Record query)) -mkResponse :: forall handlerRes res docRoute - . Resp.ToSpecResponse docRoute handlerRes res +mkResponse :: forall handlerRes res docRoute m + . MonadAff m + => Resp.ToSpecResponse docRoute handlerRes res => Resp.EncodeResponse res - => Proxy docRoute -> Proxy res -> Aff handlerRes -> Result RawResponse + => Proxy docRoute -> Proxy res -> m handlerRes -> Result m RawResponse mkResponse _ _ aff = do (handlerResp :: handlerRes) <- lift $ aff (specResp :: Response res) <- Resp.toSpecResponse (Proxy :: _ docRoute) handlerResp (rawResp :: RawResponse) <- Resp.encodeResponse specResp pure rawResp -readBody :: HTTP.Request -> Aff String -readBody req = Aff.makeAff (readBody_ req) +readBody :: forall m. MonadAff m => HTTP.Request -> m String +readBody req = liftAff $ Aff.makeAff (readBody_ req) readBody_ :: HTTP.Request -> (Either Ex.Error String -> Effect Unit) -> Effect Aff.Canceler readBody_ req cb = do diff --git a/src/Payload/Server/Handlers.purs b/src/Payload/Server/Handlers.purs index 84c1b6d..82e5d72 100644 --- a/src/Payload/Server/Handlers.purs +++ b/src/Payload/Server/Handlers.purs @@ -16,6 +16,7 @@ import Data.Maybe (Maybe(..), fromMaybe) import Data.String as String import Data.Tuple (Tuple(..)) import Effect.Aff (Aff) +import Effect.Aff.Class (liftAff) import Effect.Class (liftEffect) import Foreign (readString) import Node.FS.Aff as FsAff @@ -39,11 +40,11 @@ data File = File String instance encodeResponseFile :: EncodeResponse File where encodeResponse (Response r@{ body: File path }) = do - exists <- lift $ FsAff.exists path + exists <- lift $ liftAff $ FsAff.exists path if not exists then throwError notFoundError else do - stat <- lift $ FsAff.stat path + stat <- lift $ liftAff $ FsAff.stat path if Stats.isFile stat then do fileStream <- lift $ liftEffect $ createReadStream path let mimeType = fromMaybe "text/plain" $ MimeTypes.pathToMimeType path diff --git a/src/Payload/Server/Response.purs b/src/Payload/Server/Response.purs index b68e908..aa04c1d 100644 --- a/src/Payload/Server/Response.purs +++ b/src/Payload/Server/Response.purs @@ -82,6 +82,7 @@ import Control.Monad.Except (throwError) import Data.Either (Either(..)) import Data.Maybe (Maybe(..)) import Data.Newtype (over) +import Effect.Aff.Class (class MonadAff) import Node.Stream as Stream import Payload.Headers (Headers) import Payload.Headers as Headers @@ -123,7 +124,7 @@ updateHeaders f (Response res) = Response (res { headers = f res.headers }) -- | which that type can be produced (e.g. a full response with different -- | headers or a different status code). class ToSpecResponse (docRoute :: Symbol) a b where - toSpecResponse :: Proxy docRoute -> a -> Result (Response b) + toSpecResponse :: forall m. MonadAff m => Proxy docRoute -> a -> Result m (Response b) instance toSpecResponseEitherFailureVal :: EncodeResponse a @@ -194,7 +195,7 @@ else instance toSpecResponseFail :: -- | spec under the "body" field must implement EncodeResponse. This is also -- | a good place to add a Content-Type header for the encoded response. class EncodeResponse r where - encodeResponse :: Response r -> Result RawResponse + encodeResponse :: forall m. MonadAff m => Response r -> Result m RawResponse instance encodeResponseResponseBody :: EncodeResponse ResponseBody where encodeResponse = pure else instance encodeResponseRecord :: diff --git a/src/Payload/Server/Routable.purs b/src/Payload/Server/Routable.purs index c5488dc..246c2b6 100644 --- a/src/Payload/Server/Routable.purs +++ b/src/Payload/Server/Routable.purs @@ -14,16 +14,15 @@ import Data.Bifunctor (lmap) import Data.Either (Either(..)) import Data.List (List, (:)) import Data.Symbol (class IsSymbol, reflectSymbol) -import Effect.Aff (Aff) -import Effect.Aff as Aff -import Effect.Class (liftEffect) +import Effect.Class (class MonadEffect, liftEffect) import Effect.Console (errorShow) +import Effect.Exception (Error) import Node.HTTP as HTTP import Payload.Internal.Route (DefaultParentRoute, DefaultServerRouteSpec) import Payload.Internal.UrlParsing (class ParseUrl, class ToSegments, Segment(..)) import Payload.Internal.UrlParsing as UrlParsing -import Payload.ResponseTypes (RawResponse, ResponseBody(..), Result) import Payload.ResponseTypes (Failure(..)) as Resp +import Payload.ResponseTypes (RawResponse, ResponseBody(..), Result) import Payload.Server.Handleable (class Handleable, MethodHandler, handle) import Payload.Server.Internal.GuardParsing (GuardTypes(GuardTypes)) import Payload.Server.Internal.GuardParsing as GuardParsing @@ -43,22 +42,22 @@ import Record as Record import Type.Equality (class TypeEquals) import Type.Proxy (Proxy(..)) -type RoutingTrie = Trie HandlerEntry +type RoutingTrie m = Trie (HandlerEntry m) -type HandlerEntry = - { handler :: RequestUrl -> HTTP.Request -> HTTP.Response -> Aff Outcome +type HandlerEntry m = + { handler :: RequestUrl -> HTTP.Request -> HTTP.Response -> m Outcome , route :: List Segment } -type RawHandler = RequestUrl -> HTTP.Request -> HTTP.Response -> Aff Outcome +type RawHandler m = RequestUrl -> HTTP.Request -> HTTP.Response -> m Outcome data Outcome = Success | Failure | Forward String -class Routable routesSpec guardsSpec handlers guards | +class Routable routesSpec guardsSpec handlers guards m | routesSpec guardsSpec -> handlers, guardsSpec -> guards where mkRouter :: Spec { routes :: routesSpec, guards :: guardsSpec } -> { handlers :: handlers, guards :: guards } - -> Either String RoutingTrie + -> Either String (RoutingTrie m) instance routableRootRecord :: ( @@ -81,11 +80,13 @@ instance routableRootRecord :: guardsSpec handlers guards + m ) => Routable (Record rootSpec) (Record guardsSpec) handlers - guards where + guards + m where mkRouter _ { handlers, guards } = mkRouterList (Proxy :: _ childRoutesList) @@ -105,6 +106,7 @@ class RoutableList (guardsSpec :: Row Type) handlers guards + m | routesSpecList guardsSpec -> handlers , guardsSpec -> guards where mkRouterList :: @@ -115,10 +117,10 @@ class RoutableList -> Proxy (Record guardsSpec) -> handlers -> guards - -> RoutingTrie - -> Either String RoutingTrie + -> RoutingTrie m + -> Either String (RoutingTrie m) -instance routableListNil :: RoutableList RL.Nil basePath baseParams baseGuards guardsSpec handlers guards where +instance routableListNil :: RoutableList RL.Nil basePath baseParams baseGuards guardsSpec handlers guards m where mkRouterList _ _ _ _ _ _ _ trie = Right trie instance routableListCons :: @@ -127,13 +129,14 @@ instance routableListCons :: , IsSymbol method , Row.Union spec DefaultServerRouteSpec mergedSpec , Row.Nub mergedSpec specWithDefaults - , Handleable (Route method path (Record specWithDefaults)) handler basePath baseParams baseGuards guardsSpec (Record guards) - , RoutableList remRoutes basePath baseParams baseGuards guardsSpec (Record handlers) (Record guards) + , Handleable (Route method path (Record specWithDefaults)) handler basePath baseParams baseGuards guardsSpec (Record guards) m + , RoutableList remRoutes basePath baseParams baseGuards guardsSpec (Record handlers) (Record guards) m , Row.Cons routeName handler h' handlers , Symbol.Append basePath path fullPath , ParseUrl fullPath urlParts , ToSegments urlParts + , MonadEffect m ) => RoutableList (RL.Cons routeName (Route method path (Record spec)) remRoutes) basePath baseParams @@ -141,6 +144,7 @@ instance routableListCons :: guardsSpec (Record handlers) (Record guards) + m where mkRouterList _ basePath baseParams baseGuards guardsSpec handlers guards trie = do newTrie <- insertRoute (Lit method : routePath) handler trie @@ -162,18 +166,18 @@ instance routableListCons :: routePath :: List Segment routePath = UrlParsing.asSegments (Proxy :: Proxy fullPath) - handler :: RawHandler + handler :: RawHandler m handler url req res = methodHandler url req res # executeHandler res - headHandler :: RawHandler + headHandler :: RawHandler m headHandler url req res = methodHandler url req res <#> Resp.setBody EmptyBody # executeHandler res - methodHandler :: MethodHandler + methodHandler :: MethodHandler _ methodHandler = handle (Proxy :: _ basePath) baseParams @@ -186,21 +190,17 @@ instance routableListCons :: payloadHandler :: handler payloadHandler = get (Proxy :: Proxy routeName) handlers -executeHandler :: HTTP.Response -> Result RawResponse -> Aff Outcome +executeHandler :: forall m. MonadEffect m => HTTP.Response -> Result m RawResponse -> m Outcome executeHandler res mHandler = do - result <- Aff.attempt $ runExceptT mHandler + result <- runExceptT mHandler case result of - Right (Right rawResponse) -> do + Right rawResponse -> do liftEffect $ sendResponse res rawResponse pure Success - Right (Left (Resp.Error errorResp)) -> do + Left (Resp.Error errorResp) -> do liftEffect $ sendResponse res errorResp pure Failure - Right (Left (Resp.Forward error)) -> pure (Forward error) - Left error -> do - liftEffect $ errorShow error - liftEffect $ sendResponse res (Resp.internalError (StringBody "Internal error")) - pure Failure + Left (Resp.Forward error) -> pure (Forward error) instance routableListConsRoutes :: ( IsSymbol parentName @@ -227,17 +227,18 @@ instance routableListConsRoutes :: -- Recurse through child routes , RowToList childRoutes childRoutesList , Symbol.Append basePath path childBasePath - , RoutableList childRoutesList childBasePath childParams childGuards guardsSpec (Record childHandlers) (Record guards) + , RoutableList childRoutesList childBasePath childParams childGuards guardsSpec (Record childHandlers) (Record guards) m -- Iterate through rest of list routes - , RoutableList remRoutes basePath baseParams baseGuards guardsSpec (Record handlers) (Record guards) + , RoutableList remRoutes basePath baseParams baseGuards guardsSpec (Record handlers) (Record guards) m ) => RoutableList (RL.Cons parentName (Routes path (Record parentSpec)) remRoutes) basePath baseParams baseGuards guardsSpec (Record handlers) - (Record guards) where + (Record guards) + m where mkRouterList _ basePath baseParams baseGuards guardsSpec handlers guards trie = case trieWithChildRoutes of Right newTrie -> mkRouterList (Proxy :: Proxy remRoutes) @@ -263,7 +264,7 @@ instance routableListConsRoutes :: guards trie -insertRoute :: List Segment -> RawHandler -> RoutingTrie -> Either String RoutingTrie +insertRoute :: forall m. List Segment -> RawHandler m -> RoutingTrie m -> Either String (RoutingTrie m) insertRoute route handler trie = lmap wrapError $ Trie.insert {route, handler} route trie where handlerEntry = { route, handler } diff --git a/test/Helpers.purs b/test/Helpers.purs index f44912a..0d8539a 100644 --- a/test/Helpers.purs +++ b/test/Helpers.purs @@ -16,6 +16,7 @@ import Data.Maybe (Maybe(..)) import Data.Tuple (Tuple(..)) import Effect.Aff (Aff, error, throwError) import Effect.Aff as Aff +import Effect.Class (class MonadEffect) import Payload.Client.Response (ClientResponse) import Payload.Headers (Headers) import Payload.Headers as Headers @@ -28,14 +29,25 @@ import Test.Unit.Assert as Assert withServer :: forall routesSpec guardsSpec handlers guards - . Routable routesSpec guardsSpec handlers guards + . Routable routesSpec guardsSpec handlers guards Aff => Spec { routes :: routesSpec, guards :: guardsSpec } -> { handlers :: handlers, guards :: guards } -> Aff Unit -> Aff Unit -withServer apiSpec api_ aff = do +withServer = withServer' identity + +withServer' + :: forall routesSpec guardsSpec handlers guards m + . MonadEffect m + => Routable routesSpec guardsSpec handlers guards m + => (m ~> Aff) + -> Spec { routes :: routesSpec, guards :: guardsSpec } + -> { handlers :: handlers, guards :: guards } + -> Aff Unit + -> Aff Unit +withServer' runM apiSpec api_ aff = do let opts = Payload.defaultOpts { logLevel = Payload.LogError, port = 3000 } - whileServerRuns (Payload.startGuarded opts apiSpec api_) aff + whileServerRuns (Payload.startGuarded' runM opts apiSpec api_) aff whileServerRuns :: Aff (Either String Payload.Server) @@ -51,14 +63,25 @@ whileServerRuns runServer doWhileRunning = do completed (Right server) = Payload.close server withRoutes :: forall routesSpec handlers - . Routable routesSpec {} handlers {} + . Routable routesSpec {} handlers {} Aff => Spec routesSpec -> handlers -> Aff Unit -> Aff Unit -withRoutes _ handlers = - withServer (Spec :: Spec { guards :: {}, routes :: routesSpec }) - { guards: {}, handlers } +withRoutes = withRoutes' identity + +withRoutes' :: forall routesSpec handlers m + . MonadEffect m + => Routable routesSpec {} handlers {} m + => (m ~> Aff) + -> Spec routesSpec + -> handlers + -> Aff Unit + -> Aff Unit +withRoutes' runM _ handlers = + withServer' runM + (Spec :: Spec { guards :: {}, routes :: routesSpec }) + { guards: {}, handlers } type ApiResponse = { status :: Int diff --git a/test/Main.purs b/test/Main.purs index 36b9916..6b4420c 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -8,6 +8,7 @@ import Payload.Examples.Basic.Test as BasicExample import Payload.Examples.Files.Test as FilesExample import Payload.Examples.Hello.Test as HelloExample import Payload.Examples.Movies.Test as MoviesExample +import Payload.Examples.Transformer.Test as TransformerExample import Payload.Test.Config (defaultConfig) import Payload.Test.Integration.Client.Errors as ClientErrorsTest import Payload.Test.Integration.Client.Methods as ClientMethodsTest @@ -77,6 +78,7 @@ tests = do BasicExample.tests cfg FilesExample.tests MoviesExample.tests cfg + TransformerExample.tests main :: Effect Unit main = Aff.launchAff_ $ do