Support for monad transformers; resolves #7.

Author: nsaunders

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 }

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

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
 

src/Payload/Server.purs

@@ -4,6 +4,7 @@ module Payload.Server
        , start_
        , startGuarded
        , startGuarded_
+       , startGuarded'
        , Options
        , defaultOpts
        , LogLevel(..)
@@ -23,9 +24,9 @@ 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 Effect.Exception (Error, message)
 import Node.HTTP as HTTP
 import Node.URL (URL)
 import Node.URL as Url
@@ -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 $ message e
+          writeResponse res (internalError (StringBody ""))
+        _ ->
+          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

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