From 3fcb3ad1a3a0882dee86f3ed5baeb5148c588cb9 Mon Sep 17 00:00:00 2001 From: ambroslins Date: Mon, 16 Oct 2023 17:29:36 +0200 Subject: [PATCH 1/3] Add list instance for the toServer class --- mig/src/Mig/Core/Class/Monad.hs | 1 + mig/src/Mig/Core/Class/Server.hs | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/mig/src/Mig/Core/Class/Monad.hs b/mig/src/Mig/Core/Class/Monad.hs index 2f5db44..79c9bef 100644 --- a/mig/src/Mig/Core/Class/Monad.hs +++ b/mig/src/Mig/Core/Class/Monad.hs @@ -13,3 +13,4 @@ type family MonadOf a :: (Type -> Type) where MonadOf (Request -> m (Maybe Response)) = m MonadOf (f m) = m MonadOf (a -> b) = MonadOf b + MonadOf [a] = MonadOf a diff --git a/mig/src/Mig/Core/Class/Server.hs b/mig/src/Mig/Core/Class/Server.hs index 74a563e..28e8033 100644 --- a/mig/src/Mig/Core/Class/Server.hs +++ b/mig/src/Mig/Core/Class/Server.hs @@ -62,6 +62,10 @@ class ToServer a where instance ToServer (Server m) where toServer = id +-- list +instance (ToServer a) => ToServer [a] where + toServer = foldMap toServer + -- outputs instance (MonadIO m, IsResp a, IsMethod method) => ToServer (Send method m a) where toServer a = Server $ Api.HandleRoute (toRoute a) From cd9c23d265b1b45a23b750b9e2502909697e494f Mon Sep 17 00:00:00 2001 From: ambroslins Date: Mon, 16 Oct 2023 17:41:27 +0200 Subject: [PATCH 2/3] Remove unnecessary from examples --- examples/mig-example-apps/Counter/Main.hs | 7 ++-- examples/mig-example-apps/Html/src/Server.hs | 18 +++++----- examples/mig-example-apps/JsonApi/Server.hs | 9 +++-- examples/mig-example-apps/RouteArgs/Main.hs | 36 +++++++++---------- .../mig-example-apps/RouteArgsClient/Main.hs | 36 +++++++++---------- 5 files changed, 51 insertions(+), 55 deletions(-) diff --git a/examples/mig-example-apps/Counter/Main.hs b/examples/mig-example-apps/Counter/Main.hs index 85f4af7..bcc0793 100644 --- a/examples/mig-example-apps/Counter/Main.hs +++ b/examples/mig-example-apps/Counter/Main.hs @@ -57,10 +57,9 @@ initEnv = Env <$> newIORef 0 server :: Server App server = "counter" - /. mconcat - [ "get" /. handleGet - , "put" /. handlePut - ] + /. [ "get" /. handleGet + , "put" /. handlePut + ] -- | Get handler. It logs the call and returns current state handleGet :: Get App (Resp Int) diff --git a/examples/mig-example-apps/Html/src/Server.hs b/examples/mig-example-apps/Html/src/Server.hs index 244557c..2f892b3 100644 --- a/examples/mig-example-apps/Html/src/Server.hs +++ b/examples/mig-example-apps/Html/src/Server.hs @@ -24,10 +24,9 @@ server site = logRoutes $ mconcat [ "blog" - /. mconcat - [ readServer - , writeServer - ] + /. [ readServer + , writeServer + ] , defaultPage , addFavicon $ "static" /. staticFiles resourceFiles ] @@ -37,7 +36,7 @@ server site = -- server to read info. -- We can read blog posts and quotes. readServer = - mconcat + toServer [ "read" /. mconcat [ "post" /. handleBlogPost site @@ -49,14 +48,13 @@ server site = -- server to write new blog posts writeServer = "write" - /. mconcat - [ toServer $ handleWriteForm site - , toServer $ handleWriteSubmit site - ] + /. [ toServer $ handleWriteForm site + , toServer $ handleWriteSubmit site + ] -- default main page defaultPage = - mconcat + toServer [ "/" /. handleGreeting site , "index.html" /. handleGreeting site ] diff --git a/examples/mig-example-apps/JsonApi/Server.hs b/examples/mig-example-apps/JsonApi/Server.hs index a8284bd..17ed4b5 100644 --- a/examples/mig-example-apps/JsonApi/Server.hs +++ b/examples/mig-example-apps/JsonApi/Server.hs @@ -20,15 +20,14 @@ server env = setSwagger $ withTrace $ "api/v1/weather" - /. mconcat - [ auth - , withAuth env $: app - ] + /. [ auth + , withAuth env $: app + ] where auth = "get/auth-token" /. requestAuthToken env app = - mconcat + toServer [ "get/weather" /. getWeather env , "update" /. updateWeather env ] diff --git a/examples/mig-example-apps/RouteArgs/Main.hs b/examples/mig-example-apps/RouteArgs/Main.hs index 22b9e38..635a5c5 100644 --- a/examples/mig-example-apps/RouteArgs/Main.hs +++ b/examples/mig-example-apps/RouteArgs/Main.hs @@ -23,24 +23,24 @@ routeArgs = withSwagger def $ withTrace $ "api" - /. mconcat - -- no args, constnat output - [ "hello/world" /. helloWorld - , -- required query param and custom header - "succ" /. handleSucc - , -- optional query param - "succ-opt" /. handleSuccOpt - , -- several query params - "add" /. handleAdd - , -- query flag - "add-if" /. handleAddIf - , -- capture - "mul" /. handleMul - , -- json body as input - "add-json" /. handleAddJson - , -- return error - "square-root" /. handleSquareRoot - ] + /. + -- no args, constnat output + [ "hello/world" /. helloWorld + , -- required query param and custom header + "succ" /. handleSucc + , -- optional query param + "succ-opt" /. handleSuccOpt + , -- several query params + "add" /. handleAdd + , -- query flag + "add-if" /. handleAddIf + , -- capture + "mul" /. handleMul + , -- json body as input + "add-json" /. handleAddJson + , -- return error + "square-root" /. handleSquareRoot + ] where withTrace = applyMiddleware (Trace.logHttp Trace.V2) diff --git a/examples/mig-example-apps/RouteArgsClient/Main.hs b/examples/mig-example-apps/RouteArgsClient/Main.hs index 84a2e5d..cb907ea 100644 --- a/examples/mig-example-apps/RouteArgsClient/Main.hs +++ b/examples/mig-example-apps/RouteArgsClient/Main.hs @@ -82,24 +82,24 @@ helloWorld server :: Server Client server = "api" - /. mconcat - -- no args, constnat output - [ "hello/world" /. helloWorld - , -- required query param and custom header - "succ" /. handleSucc - , -- optional query param - "succ-opt" /. handleSuccOpt - , -- several query params - "add" /. handleAdd - , -- query flag - "add-if" /. handleAddIf - , -- capture - "mul" /. handleMul - , -- json body as input - "add-json" /. handleAddJson - , -- return error - "square-root" /. handleSquareRoot - ] + /. + -- no args, constnat output + [ "hello/world" /. helloWorld + , -- required query param and custom header + "succ" /. handleSucc + , -- optional query param + "succ-opt" /. handleSuccOpt + , -- several query params + "add" /. handleAdd + , -- query flag + "add-if" /. handleAddIf + , -- capture + "mul" /. handleMul + , -- json body as input + "add-json" /. handleAddJson + , -- return error + "square-root" /. handleSquareRoot + ] data AddInput = AddInput { a :: Int From b366507e4498888ea229cc67b84e4e2a5c5976b0 Mon Sep 17 00:00:00 2001 From: ambroslins Date: Mon, 16 Oct 2023 17:50:08 +0200 Subject: [PATCH 3/3] Update docs with list instance --- docs/src/01-hello-world.md | 12 ++++++++++++ docs/src/02-request-anatomy.md | 6 ++---- docs/src/04-other-monads.md | 7 +++---- docs/src/06-json-api-example.md | 7 +++---- docs/src/07-blog-post-example.md | 21 +++++++++------------ 5 files changed, 29 insertions(+), 24 deletions(-) diff --git a/docs/src/01-hello-world.md b/docs/src/01-hello-world.md index d34070a..d0ea0f7 100644 --- a/docs/src/01-hello-world.md +++ b/docs/src/01-hello-world.md @@ -298,6 +298,18 @@ to the value `Server m`. So we have the flexibility on DSL level but on the level of implementation to build the tree of handlers we use the same type. which makes type very simple. +### List instance for Servers +Because of the `ToServer a => ToServer [a]` instance we can omit the `mconcat` +most of the time. Meaning we can write the previous examples as: + +```haskell +server = + "api/v1/hello" /. + [ toServer helloGet + , toServer helloPost + ] +``` + ### The path type Let's discuss the `Path` type. diff --git a/docs/src/02-request-anatomy.md b/docs/src/02-request-anatomy.md index 707beb9..1d13bae 100644 --- a/docs/src/02-request-anatomy.md +++ b/docs/src/02-request-anatomy.md @@ -272,8 +272,7 @@ main = runServer 8085 server -- | Let's define a server server :: Server IO server = - "api" - /. mconcat + "api" /. -- no args, constnat output [ "hello/world" /. helloWorld , -- required query param and custom header @@ -387,8 +386,7 @@ Let's add a swagger to our server. Just add this line: server :: IO server = withSwagger def $ - "api" /. - mcomcat [ {- the rest of the code -} ] + "api" /. [ {- the rest of the code -} ] ``` Let's add this line to our example and restart the server. diff --git a/docs/src/04-other-monads.md b/docs/src/04-other-monads.md index 687a8aa..f5aa6a7 100644 --- a/docs/src/04-other-monads.md +++ b/docs/src/04-other-monads.md @@ -116,10 +116,9 @@ Our server has two routes: server :: Server App server = "counter" - /. mconcat - [ "get" /. handleGet - , "put" /. handlePut - ] + /. [ "get" /. handleGet + , "put" /. handlePut + ] ``` Let's define the `get` route: diff --git a/docs/src/06-json-api-example.md b/docs/src/06-json-api-example.md index ded3556..ce0260b 100644 --- a/docs/src/06-json-api-example.md +++ b/docs/src/06-json-api-example.md @@ -98,10 +98,9 @@ server :: Env -> Server IO server env = withSwagger def $ "api/v1/weather" - /. mconcat - [ auth - , withAuth env $: app - ] + /. [ auth + , withAuth env $: app + ] where auth = "get/auth-token" /. requestAuthToken env diff --git a/docs/src/07-blog-post-example.md b/docs/src/07-blog-post-example.md index 4afb58e..db300dd 100644 --- a/docs/src/07-blog-post-example.md +++ b/docs/src/07-blog-post-example.md @@ -97,10 +97,9 @@ server site = logRoutes $ mconcat [ "blog" - /. mconcat - [ readServer - , writeServer - ] + /. [ readServer + , writeServer + ] , defaultPage , addFavicon $ "static" /. staticFiles resourceFiles ] @@ -145,10 +144,9 @@ Let's define read-only pages for our site. readServer = mconcat [ "read" - /. mconcat - [ "post" /. handleBlogPost site - , "quote" /. handleQuote site - ] + /. [ "post" /. handleBlogPost site + , "quote" /. handleQuote site + ] , "list" /. handleListPosts site ] @@ -173,10 +171,9 @@ Let's define a route to add new blog posts to the site: -- server to write new blog posts writeServer = "write" - /. mconcat - [ toServer $ handleWriteForm site - , toServer $ handleWriteSubmit site - ] + /. [ toServer $ handleWriteForm site + , toServer $ handleWriteSubmit site + ] handleWriteForm :: Site -> Get (Page WritePost)