diff --git a/docs/Examples/AsyncResponse/Main.purs b/docs/Examples/AsyncResponse/Main.purs index 79192b9..afbd65d 100644 --- a/docs/Examples/AsyncResponse/Main.purs +++ b/docs/Examples/AsyncResponse/Main.purs @@ -4,8 +4,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve) import Node.Encoding (Encoding(UTF8)) import Node.FS.Aff (readTextFile) import Routing.Duplex as RD @@ -24,7 +25,7 @@ route = RD.root $ RG.sum filePath :: String filePath = "./docs/Examples/AsyncResponse/Hello" -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { route: SayHello } = readTextFile UTF8 filePath >>= ok -- | Boot up the server diff --git a/docs/Examples/BinaryRequest/Main.purs b/docs/Examples/BinaryRequest/Main.purs index bec340c..8ba0a86 100644 --- a/docs/Examples/BinaryRequest/Main.purs +++ b/docs/Examples/BinaryRequest/Main.purs @@ -4,8 +4,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve, toBuffer) +import HTTPurple (Request, Response, ServerM, ok, serve, toBuffer) import Node.Buffer (Buffer) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -22,7 +23,7 @@ route = RD.root $ RG.sum foreign import sha256sum :: Buffer -> String -- | Respond with file's sha256sum -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { body } = toBuffer body >>= sha256sum >>> ok -- | Boot up the server diff --git a/docs/Examples/BinaryResponse/Main.purs b/docs/Examples/BinaryResponse/Main.purs index 5c6072a..673804d 100644 --- a/docs/Examples/BinaryResponse/Main.purs +++ b/docs/Examples/BinaryResponse/Main.purs @@ -4,8 +4,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseHeaders, ResponseM, ServerM, header, ok', serve) +import HTTPurple (Request, ResponseHeaders, Response, ServerM, header, ok', serve) import Node.FS.Aff (readFile) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -27,7 +28,7 @@ responseHeaders :: ResponseHeaders responseHeaders = header "Content-Type" "image/png" -- | Respond with image data when run -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router = const $ readFile filePath >>= ok' responseHeaders -- | Boot up the server diff --git a/docs/Examples/Chunked/Main.purs b/docs/Examples/Chunked/Main.purs index 53c1a83..f29694c 100644 --- a/docs/Examples/Chunked/Main.purs +++ b/docs/Examples/Chunked/Main.purs @@ -7,7 +7,7 @@ import Data.Maybe (Maybe(..)) import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve) import Node.ChildProcess (defaultSpawnOptions, spawn, stdout) import Node.Stream (Readable) import Routing.Duplex as RD @@ -28,7 +28,7 @@ runScript script = liftEffect $ stdout <$> spawn "sh" [ "-c", script ] defaultSpawnOptions -- | Say 'hello world!' in chunks when run -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router = const $ runScript "echo 'hello '; sleep 1; echo 'world!'" >>= ok -- | Boot up the server diff --git a/docs/Examples/CustomStack/Main.purs b/docs/Examples/CustomStack/Main.purs index c73a6cc..617420f 100644 --- a/docs/Examples/CustomStack/Main.purs +++ b/docs/Examples/CustomStack/Main.purs @@ -2,13 +2,11 @@ module Examples.CustomStack.Main where import Prelude -import Control.Monad.Reader (class MonadAsk, ReaderT, asks, runReaderT) +import Control.Monad.Reader (class MonadAsk, asks, runReaderT) import Data.Generic.Rep (class Generic) -import Data.Maybe (Maybe(..)) -import Effect.Aff (Aff) import Effect.Aff.Class (class MonadAff) import Effect.Console (log) -import HTTPurple (Request, Response, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve') import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -24,15 +22,6 @@ route = RD.root $ RG.sum -- | A type to hold the environment for our ReaderT type Env = { name :: String } --- | A middleware that introduces a ReaderT -readerMiddleware :: - forall route. - (Request route -> ReaderT Env Aff Response) -> - Request route -> - ResponseM -readerMiddleware router request = do - runReaderT (router request) { name: "joe" } - -- | Say 'hello, joe' when run sayHello :: forall m. MonadAff m => MonadAsk Env m => Request Route -> m Response sayHello _ = do @@ -42,7 +31,7 @@ sayHello _ = do -- | Boot up the server main :: ServerM main = - serve { hostname: "localhost", port: 8080, onStarted } { route, router: readerMiddleware sayHello } + serve' (\a -> runReaderT a {name: "joe"}) { hostname: "localhost", port: 8080, onStarted } { route, router: sayHello } where onStarted = do log " ┌───────────────────────────────────────┐" diff --git a/docs/Examples/ExtensibleMiddleware/Main.purs b/docs/Examples/ExtensibleMiddleware/Main.purs index 15729ed..df0844d 100644 --- a/docs/Examples/ExtensibleMiddleware/Main.purs +++ b/docs/Examples/ExtensibleMiddleware/Main.purs @@ -6,9 +6,10 @@ import Data.Generic.Rep (class Generic) import Data.JSDate (JSDate) import Data.JSDate as JSDate import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Console (log) -import HTTPurple (ExtRequest, Middleware, Request, RequestR, ResponseM, ServerM, ok, serve) +import HTTPurple (ExtRequest, Middleware, Request, RequestR, Response, ServerM, ok, serve) import HTTPurple as Headers import Prim.Row (class Nub, class Union) import Record (merge) @@ -43,12 +44,12 @@ sayHelloRoute = RD.root $ RG.sum } -- | Say 'hello ' when run with X-Token, otherwise 'hello anonymous' -sayHello :: ExtRequest SayHello (user :: Maybe String, time :: JSDate) -> ResponseM +sayHello :: ExtRequest SayHello (user :: Maybe String, time :: JSDate) -> Aff Response sayHello { user: Just user, time } = ok $ "hello " <> user <> ", it is " <> JSDate.toDateString time <> " " <> JSDate.toTimeString time sayHello { user: Nothing, time } = ok $ "hello " <> "anonymous, it is " <> JSDate.toDateString time <> " " <> JSDate.toTimeString time -- | The stack of middlewares to use for the server -middlewareStack :: forall route. (ExtRequest route (user :: Maybe String, time :: JSDate) -> ResponseM) -> Request route -> ResponseM +middlewareStack :: forall route. (ExtRequest route (user :: Maybe String, time :: JSDate) -> Aff Response) -> Request route -> Aff Response middlewareStack = authenticator <<< requestTime -- | Boot up the server diff --git a/docs/Examples/Headers/Main.purs b/docs/Examples/Headers/Main.purs index 50457de..19681ec 100644 --- a/docs/Examples/Headers/Main.purs +++ b/docs/Examples/Headers/Main.purs @@ -3,8 +3,9 @@ module Examples.Headers.Main where import Prelude import Data.Generic.Rep (class Generic) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseHeaders, ResponseM, ServerM, ok', serve, (!@)) +import HTTPurple (Request, ResponseHeaders, Response, ServerM, ok', serve, (!@)) import HTTPurple.Headers (headers) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -26,7 +27,7 @@ responseHeaders = headers } -- | Route to the correct handler -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { headers } = ok' responseHeaders $ headers !@ "X-Input" -- | Boot up the server diff --git a/docs/Examples/Middleware/Main.purs b/docs/Examples/Middleware/Main.purs index 11c83f6..c36c2c4 100644 --- a/docs/Examples/Middleware/Main.purs +++ b/docs/Examples/Middleware/Main.purs @@ -5,9 +5,10 @@ import Prelude hiding ((/)) import Data.Either (Either(..)) import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Console (log) -import HTTPurple (type (<+>), Request, ResponseM, ServerM, fullPath, header, ok, ok', serve, (<+>)) +import HTTPurple (type (<+>), Request, Response, ServerM, fullPath, header, ok, ok', serve, (<+>)) import Record as Record import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -35,9 +36,9 @@ sayHelloRoute = RD.root $ RG.sum -- | A middleware that logs at the beginning and end of each request loggingMiddleware :: forall route. - (Request route -> ResponseM) -> + (Request route -> Aff Response) -> Request route -> - ResponseM + Aff Response loggingMiddleware router request = do liftEffect $ log $ "Request starting for " <> path response <- router request @@ -50,9 +51,9 @@ loggingMiddleware router request = do -- | wasn't already in the response headerMiddleware :: forall route. - (Request route -> ResponseM) -> + (Request route -> Aff Response) -> Request route -> - ResponseM + Aff Response headerMiddleware router request = do response@{ headers } <- router request pure $ response { headers = header' <> headers } @@ -63,18 +64,18 @@ headerMiddleware router request = do -- | router when requesting /middleware pathMiddleware :: forall route. - (Request route -> ResponseM) -> + (Request route -> Aff Response) -> Request (Middleware <+> route) -> - ResponseM + Aff Response pathMiddleware _ { route: Left Middleware } = ok "Middleware!" pathMiddleware router request@{ route: Right r } = router $ Record.set (Proxy :: _ "route") r request -- | Say 'hello' when run, and add a default value to the X-Middleware header -sayHello :: Request SayHello -> ResponseM +sayHello :: Request SayHello -> Aff Response sayHello _ = ok' (header "X-Middleware" "router") "hello" -- | The stack of middlewares to use for the server -middlewareStack :: forall route. (Request route -> ResponseM) -> Request (Either Middleware route) -> ResponseM +middlewareStack :: forall route. (Request route -> Aff Response) -> Request (Either Middleware route) -> Aff Response middlewareStack = loggingMiddleware <<< headerMiddleware <<< pathMiddleware -- | Boot up the server diff --git a/docs/Examples/MultiRoute/Main.purs b/docs/Examples/MultiRoute/Main.purs index 6a1ba71..860d923 100644 --- a/docs/Examples/MultiRoute/Main.purs +++ b/docs/Examples/MultiRoute/Main.purs @@ -4,8 +4,9 @@ import Prelude hiding ((/)) import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -22,7 +23,7 @@ route = RD.root $ RG.sum } -- | Specify the routes -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { route: Hello } = ok "hello" router { route: GoodBye } = ok "goodbye" diff --git a/docs/Examples/NodeMiddleware/Main.purs b/docs/Examples/NodeMiddleware/Main.purs index 000bfe5..89a2242 100644 --- a/docs/Examples/NodeMiddleware/Main.purs +++ b/docs/Examples/NodeMiddleware/Main.purs @@ -6,8 +6,9 @@ import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) import Data.Nullable (Nullable) import Data.Nullable as Nullable +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (ExtRequest, NodeMiddleware, NodeMiddlewareStack(..), ResponseM, ServerM, ok, serveNodeMiddleware, usingMiddleware) +import HTTPurple (ExtRequest, NodeMiddleware, NodeMiddlewareStack(..), Response, ServerM, ok, serveNodeMiddleware, usingMiddleware) import Routing.Duplex as RD import Routing.Duplex.Generic as RG @@ -30,7 +31,7 @@ sayHelloRoute = RD.root $ RG.sum } -- | Say 'hello ' when run with X-Token, otherwise 'hello anonymous' -sayHello :: ExtRequest SayHello AuthenticatorR -> ResponseM +sayHello :: ExtRequest SayHello AuthenticatorR -> Aff Response sayHello { user } = case Nullable.toMaybe user of Just u -> ok $ "hello " <> u Nothing -> ok $ "hello " <> "anonymous" diff --git a/docs/Examples/PathSegments/Main.purs b/docs/Examples/PathSegments/Main.purs index d6f2dc5..27d3bfc 100644 --- a/docs/Examples/PathSegments/Main.purs +++ b/docs/Examples/PathSegments/Main.purs @@ -4,9 +4,9 @@ import Prelude hiding ((/)) import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD import Routing.Duplex.Generic as G @@ -23,7 +23,7 @@ route = RD.root $ G.sum } -- | Specify the routes -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { route: Segment elem } = ok elem router { route: ManySegments elems } = ok $ show elems diff --git a/docs/Examples/Post/Main.purs b/docs/Examples/Post/Main.purs index a360eb0..2a30f87 100644 --- a/docs/Examples/Post/Main.purs +++ b/docs/Examples/Post/Main.purs @@ -4,8 +4,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Method(Post), Request, ResponseM, ServerM, notFound, ok, serve, toString) +import HTTPurple (Method(Post), Request, Response, ServerM, notFound, ok, serve, toString) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD import Routing.Duplex.Generic as G @@ -20,7 +21,7 @@ route = RD.root $ G.sum } -- | Route to the correct handler -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { body, method: Post } = toString body >>= ok router _ = notFound diff --git a/docs/Examples/QueryParameters/Main.purs b/docs/Examples/QueryParameters/Main.purs index 01b4dd3..d77cc77 100644 --- a/docs/Examples/QueryParameters/Main.purs +++ b/docs/Examples/QueryParameters/Main.purs @@ -5,8 +5,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) import Effect (Effect) +import Effect.Aff (Aff) import Effect.Class.Console (log) -import HTTPurple (Request, ResponseM, ServerM, notFound, ok, serve) +import HTTPurple (Request, Response, ServerM, notFound, ok, serve) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD import Routing.Duplex.Generic as G @@ -21,7 +22,7 @@ route = RD.root $ G.sum } -- | Specify the routes -router :: Request Route -> ResponseM +router :: Request Route -> Aff Response router { route: (Route { foo: true }) } = ok "foo" router { route: (Route { bar: Just "test" }) } = ok "bar" router { route: (Route { bar: Just _ }) } = ok "" diff --git a/docs/Examples/SSL/Main.purs b/docs/Examples/SSL/Main.purs index 43299e6..e1e527e 100644 --- a/docs/Examples/SSL/Main.purs +++ b/docs/Examples/SSL/Main.purs @@ -4,8 +4,9 @@ import Prelude import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) import Effect.Console (log) -import HTTPurple (Request, ResponseM, ServerM, ok, serve) +import HTTPurple (Request, Response, ServerM, ok, serve) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD import Routing.Duplex.Generic as G @@ -29,7 +30,7 @@ key :: String key = "./docs/Examples/SSL/Key.key" -- | Say 'hello world!' when run -sayHello :: Request Route -> ResponseM +sayHello :: Request Route -> Aff Response sayHello _ = ok "hello world!" -- | Boot up the server diff --git a/src/HTTPurple/Server.purs b/src/HTTPurple/Server.purs index 9876219..00f3d10 100644 --- a/src/HTTPurple/Server.purs +++ b/src/HTTPurple/Server.purs @@ -67,7 +67,7 @@ type ListenOptionsR m = , backlog :: Maybe Int , closingHandler :: Maybe ClosingHandler , notFoundHandler :: Maybe (Request Unit -> m Response) - , onStarted :: Maybe (m Unit) + , onStarted :: Maybe (Effect Unit) , certFile :: Maybe String , keyFile :: Maybe String ) @@ -255,7 +255,7 @@ serveInternal performM inputOptions maybeNodeMiddleware settings = do server <- liftEffect $ HTTP.createServer liftEffect $ EE.on_ HServer.requestH handler server pure $ HServer.toNetServer server - liftEffect $ EE.on_ listeningH (launchAff_ $ performM onStarted) netServer + liftEffect $ EE.on_ listeningH onStarted netServer liftEffect $ listenTcp netServer options let closingHandler = NServer.close netServer srv <- registerClosingHandler filledOptions.closingHandler (\eff -> eff *> closingHandler) @@ -276,6 +276,36 @@ serve inputOptions { route, router } = do extendedSettings = { route, router: asExtended router } serveInternal identity inputOptions Nothing extendedSettings +--| `serve` generalized to any MonadAff +--| +--| ``` +--| module Main where +--| +--| import Prelude hiding ((/)) +--| import HTTPurple +--| +--| import Effect (Effect) +--| import Effect.Aff (Aff, launchAff_) +--| import Effect.Console (log) +--| import Control.Monad.Logger.Trans (LoggerT) +--| +--| type M = LoggerT Aff +--| +--| data Route = Hello String +--| +--| route :: RouteDuplex' +--| route = mkRoute { "Hello": "hello" / segment } +--| +--| router :: ExtRequest Route () -> Response M +--| router {route: Hello m} = ok $ "hi, " <> m <> "!" +--| +--| main :: Effect Unit +--| main = +--| let +--| launchM m = runLoggerT m (liftEffect <<< log) +--| in +--| serve' launchM {port: 8080} {route, router} +--| ``` serve' :: forall m route from fromRL via missing missingList. MonadAff m => diff --git a/test/Test/HTTPurple/ServerSpec.purs b/test/Test/HTTPurple/ServerSpec.purs index 6a5224a..5f0c039 100644 --- a/test/Test/HTTPurple/ServerSpec.purs +++ b/test/Test/HTTPurple/ServerSpec.purs @@ -4,11 +4,12 @@ import Prelude import Control.Monad.Except (throwError) import Data.Generic.Rep (class Generic) +import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Exception (error) import Foreign.Object (empty) import HTTPurple.Request (Request) -import HTTPurple.Response (ResponseM, ok) +import HTTPurple.Response (Response, ok) import HTTPurple.Server (serve) import Routing.Duplex (RouteDuplex') import Routing.Duplex as RD @@ -27,7 +28,7 @@ route = RD.root $ G.sum { "Test": RD.path "test" RG.noArgs } -mockRouter :: Request Route -> ResponseM +mockRouter :: Request Route -> Aff Response mockRouter { route: Test } = ok $ RD.print route Test serveSpec :: Test