diff --git a/examples/mig-example-apps/HtmlTemplate/src/Init.hs b/examples/mig-example-apps/HtmlTemplate/src/Init.hs index 391feb8..75befd1 100644 --- a/examples/mig-example-apps/HtmlTemplate/src/Init.hs +++ b/examples/mig-example-apps/HtmlTemplate/src/Init.hs @@ -38,7 +38,7 @@ initSite = do Site { readBlogPost = mockRead env , writeBlogPost = mockWriteBlogPost env - , listBlogPosts = readIORef env.blogPosts + , listBlogPosts = fmap toBlogPostLink <$> readIORef env.blogPosts , readQuote = Quote <$> randomQuote , logInfo = logInfo , cleanup = do diff --git a/examples/mig-example-apps/HtmlTemplate/src/Interface.hs b/examples/mig-example-apps/HtmlTemplate/src/Interface.hs index 8a5abf7..62768af 100644 --- a/examples/mig-example-apps/HtmlTemplate/src/Interface.hs +++ b/examples/mig-example-apps/HtmlTemplate/src/Interface.hs @@ -14,7 +14,7 @@ with outside world: DBs, logger. data Site = Site { readBlogPost :: BlogPostId -> IO (Maybe BlogPost) , writeBlogPost :: SubmitBlogPost -> IO BlogPostId - , listBlogPosts :: IO [BlogPost] + , listBlogPosts :: IO [BlogPostLink] , readQuote :: IO Quote , logInfo :: Text -> IO () , cleanup :: IO () diff --git a/examples/mig-example-apps/HtmlTemplate/src/Server.hs b/examples/mig-example-apps/HtmlTemplate/src/Server.hs index 2ba8112..9366e68 100644 --- a/examples/mig-example-apps/HtmlTemplate/src/Server.hs +++ b/examples/mig-example-apps/HtmlTemplate/src/Server.hs @@ -28,7 +28,7 @@ initServer site = logRoutes $ server (initRoutes site) <> staticServer addFavicon $ "static" /. staticFiles resourceFiles resourceFiles :: [(FilePath, ByteString)] - resourceFiles = $(embedRecursiveDir "Html/resources") + resourceFiles = $(embedRecursiveDir "HtmlTemplate/resources") addFavicon :: Server IO -> Server IO addFavicon = addPathLink "favicon.ico" "static/lambda-logo.png" @@ -59,14 +59,14 @@ handleGreeting site = -- | Read blog post by id handleBlogPost :: Site -> BlogPostRoute -handleBlogPost site (Optional mBlogId) = Send $ - case mBlogId of - Nothing -> toPage . ViewBlogPost <$> randomBlogPost site - Just blogId -> - maybe - (toErrorPage notFound404 $ PostNotFound blogId) - (toPage . ViewBlogPost) - <$> site.readBlogPost blogId +handleBlogPost site (Optional mBlogId) = Send $ do + blogId <- getId + maybe + (toErrorPage notFound404 $ PostNotFound blogId) + (toPage . ViewBlogPost) + <$> site.readBlogPost blogId + where + getId = maybe (randomBlogPost site) pure mBlogId -- | Read random quote handleQuote :: Site -> QuoteRoute @@ -97,9 +97,9 @@ logRoute site route = do site.logInfo $ route <> " page visited" -- | Get random blog post -randomBlogPost :: Site -> IO BlogPost +randomBlogPost :: Site -> IO BlogPostId randomBlogPost site = - oneOf =<< site.listBlogPosts + fmap (.blogPostId) $ oneOf =<< site.listBlogPosts toPage :: (ToMarkup a) => a -> Resp Html toPage = ok . toMarkup . Page diff --git a/examples/mig-example-apps/HtmlTemplate/src/Types.hs b/examples/mig-example-apps/HtmlTemplate/src/Types.hs index caef6b7..63b5e87 100644 --- a/examples/mig-example-apps/HtmlTemplate/src/Types.hs +++ b/examples/mig-example-apps/HtmlTemplate/src/Types.hs @@ -7,6 +7,8 @@ module Types ( BlogPostId (..), BlogPostView (..), BlogPost (..), + BlogPostLink (..), + toBlogPostLink, Quote (..), SubmitBlogPost (..), ) where @@ -18,23 +20,39 @@ import Mig.Html.IO -- | Web-page for our site newtype Page a = Page a --- | Greeting page -newtype Greeting = Greeting [BlogPost] - -- | Form to submit new post data WritePost = WritePost --- | List all posts -newtype ListPosts = ListPosts [BlogPost] - -- | Blog post id newtype BlogPostId = BlogPostId {unBlogPostId :: UUID} +mapDerive deriveNewtypeParam [''BlogPostId] + +data Link = Link + { href :: Text + , name :: Text + } + deriving (Generic, ToJSON) + data BlogPostView = ViewBlogPost BlogPost | -- | error: post not found by id PostNotFound BlogPostId +data BlogPostLink = BlogPostLink + { blogPostId :: BlogPostId + , title :: Text + } + +toBlogPostLink :: BlogPost -> BlogPostLink +toBlogPostLink post = BlogPostLink post.id post.title + +-- | Greeting page +newtype Greeting = Greeting [BlogPostLink] + +-- | List all posts +newtype ListPosts = ListPosts [BlogPostLink] + -- | Blog post data BlogPost = BlogPost { id :: BlogPostId @@ -42,11 +60,13 @@ data BlogPost = BlogPost , createdAt :: UTCTime , content :: Text } + deriving (Generic, ToJSON) -- | A quote data Quote = Quote { content :: Text } + deriving (Generic, ToJSON) -- | Data to submit new blog post data SubmitBlogPost = SubmitBlogPost @@ -57,5 +77,4 @@ data SubmitBlogPost = SubmitBlogPost -------------------------------------------- -- derivings -mapDerive deriveNewtypeParam [''BlogPostId] deriveForm ''SubmitBlogPost diff --git a/examples/mig-example-apps/HtmlTemplate/src/View.hs b/examples/mig-example-apps/HtmlTemplate/src/View.hs index dbc4b2c..e274721 100644 --- a/examples/mig-example-apps/HtmlTemplate/src/View.hs +++ b/examples/mig-example-apps/HtmlTemplate/src/View.hs @@ -1,103 +1,123 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | html renderers. View for all pages module View () where import Api (Urls (..), urls) -import Data.List qualified as List +import Data.Aeson qualified as Json +import Data.Text.Lazy qualified as LazyText import Mig +import Mig.Html (Link (..)) +import Text.Blaze.Html.Renderer.Text qualified as H import Text.Blaze.Html5 qualified as H -import Text.Blaze.Html5.Attributes qualified as HA +import Text.Mustache +import Text.Mustache.Compile.TH qualified as TH import Types +renderMustacheHtml :: (ToJSON a) => Template -> a -> Html +renderMustacheHtml template value = + H.preEscapedLazyText $ renderMustache template (toJSON value) + +-- | Templates for the site +data Templates = Templates + { main :: Template + , greeting :: Template + , post :: Template + , quote :: Template + , writeForm :: Template + , listPosts :: Template + , postNotFound :: Template + } + +-- | Loads templates with template haskell as pure values +templates :: Templates +templates = + Templates + { main = $(TH.compileMustacheFile "HtmlTemplate/templates/main.html") + , greeting = $(TH.compileMustacheFile "HtmlTemplate/templates/greeting.html") + , post = $(TH.compileMustacheFile "HtmlTemplate/templates/post.html") + , quote = $(TH.compileMustacheFile "HtmlTemplate/templates/quote.html") + , writeForm = $(TH.compileMustacheFile "HtmlTemplate/templates/writeForm.html") + , listPosts = $(TH.compileMustacheFile "HtmlTemplate/templates/listPosts.html") + , postNotFound = $(TH.compileMustacheFile "HtmlTemplate/templates/postNotFound.html") + } + +data MainPage = MainPage + { title :: Text + , menuLinks :: [Link] + , content :: LazyText.Text + } + deriving (Generic, ToJSON) + -- writes the template for main page instance (ToMarkup a) => ToMarkup (Page a) where toMarkup page = case page of - Page a -> siteTemplate (H.toMarkup a) - --- | Main site template -siteTemplate :: Html -> Html -siteTemplate content = H.html $ do - H.head $ do - H.meta H.! HA.charset "UTF-8" - H.link H.! HA.rel "stylesheet" H.! HA.href "https://fonts.googleapis.com/css?family=Roboto:300,300italic,700,700italic" - H.link H.! HA.rel "stylesheet" H.! HA.href "/static/milligram.min.css" - H.body $ H.div H.! HA.style "margin-left:4%; margin-top: 3%; font-size: 110%" $ do - H.div H.! HA.class_ "container" $ do - H.div H.! HA.class_ "row" $ do - H.div H.! HA.class_ "column column-20" $ menu - H.div H.! HA.class_ "column column-75 column-offset-5" $ content - where - menu = do - H.div $ do - H.img H.! HA.src "/static/haskell-logo.png" H.! HA.alt "blog logo" H.! HA.width "100pt" H.! HA.style "margin-bottom: 15pt" - H.ul H.! HA.style "list-style: none" $ do - item (renderUrl urls.greeting) "main page" - item (renderUrl $ urls.blogPost $ Optional Nothing) "next post" - item (renderUrl urls.quote) "next quote" - item (renderUrl urls.writeForm) "write new post" - item (renderUrl urls.listPosts) "list all posts" + Page a -> + renderMustacheHtml templates.main $ + MainPage + { title = "Blog example" + , menuLinks = siteMenuLinks + , content = H.renderHtml (H.toMarkup a) + } - item ref name = - H.li $ H.a H.! HA.href ref $ H.text name +siteMenuLinks :: [Link] +siteMenuLinks = + [ Link + { name = "main page" + , href = urls.greeting + } + , Link + { name = "next post" + , href = urls.blogPost $ Optional Nothing + } + , Link + { name = "next quote" + , href = urls.quote + } + , Link + { name = "write new post" + , href = urls.writeForm + } + , Link + { name = "list all posts" + , href = urls.listPosts + } + ] -- Rendering of the greeting page instance ToMarkup Greeting where - toMarkup (Greeting posts) = do - H.div $ do - H.h2 "Welcome to blog site example" - H.p "You can get random poem or random quote from menu bar" - toMarkup (ListPosts posts) + toMarkup (Greeting posts) = renderMustacheHtml templates.greeting $ toPostLinks posts -- Rendering of the form to submit the post instance ToMarkup WritePost where - toMarkup WritePost = do - H.div $ do - H.h2 "Write new post" - H.form H.! HA.method "POST" H.! HA.action "/blog/write" $ do - inputText "title" - inputContent "content" - submit "Save blog post" - where - inputText name = H.div $ do - H.p (H.text $ "Input " <> name) - H.textarea H.! HA.rows "1" H.! HA.cols "100" H.! HA.id (H.toValue name) H.! HA.name (H.toValue name) $ pure () - - inputContent name = H.div $ do - H.p (H.text $ "Input " <> name) - H.textarea H.! HA.rows "10" H.! HA.cols "100" H.! HA.id (H.toValue name) H.! HA.name (H.toValue name) $ pure () - - submit :: Text -> Html - submit name = H.div $ H.input H.! HA.type_ "submit" H.! HA.value (H.toValue name) + toMarkup WritePost = renderMustacheHtml templates.writeForm $ Link urls.writeForm "Submit" instance ToMarkup BlogPostView where toMarkup = \case ViewBlogPost post -> toMarkup post - PostNotFound _pid -> H.p (H.text "Post not found") + PostNotFound _pid -> renderMustacheHtml templates.postNotFound () -- | Rendering of a single blog post instance ToMarkup BlogPost where - toMarkup post = - H.div $ do - H.div $ H.h2 $ H.toHtml post.title - H.div $ H.p $ H.toHtml ("Created at: " <> show post.createdAt) - H.div H.! HA.style "white-space: pre-wrap" $ - H.text post.content + toMarkup post = renderMustacheHtml templates.post post -- Rendering of a single quote instance ToMarkup Quote where - toMarkup quote = do - H.div $ H.h2 "Quote of the day:" - H.div $ H.p $ H.text quote.content + toMarkup quote = renderMustacheHtml templates.quote quote -- | Rendering of all submited posts instance ToMarkup ListPosts where - toMarkup (ListPosts posts) = - H.div $ do - H.h2 $ H.text "Posts:" - H.ul $ mapM_ (\p -> H.li $ toPostSummary p) $ List.sortOn (.createdAt) posts - where - toPostSummary post = - H.a H.! HA.href (renderUrl $ urls.blogPost $ Optional $ Just post.id) $ - H.text $ - post.title + toMarkup (ListPosts posts) = renderMustacheHtml templates.listPosts $ toPostLinks posts + +toPostLinks :: [BlogPostLink] -> Json.Value +toPostLinks posts = + Json.object ["posts" Json..= fmap toLink posts] + where + toLink :: BlogPostLink -> Link + toLink post = + Link + { href = urls.blogPost (Optional $ Just post.blogPostId) + , name = post.title + } diff --git a/examples/mig-example-apps/HtmlTemplate/templates/greeting.html b/examples/mig-example-apps/HtmlTemplate/templates/greeting.html new file mode 100644 index 0000000..fbca2b7 --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/greeting.html @@ -0,0 +1,14 @@ +
+

Welcome to blog site example

+

You can get random poem or random quote from menu bar

+
+

Posts:

+ +
+
diff --git a/examples/mig-example-apps/HtmlTemplate/templates/listPosts.html b/examples/mig-example-apps/HtmlTemplate/templates/listPosts.html new file mode 100644 index 0000000..c92808e --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/listPosts.html @@ -0,0 +1,10 @@ +
+

Posts:

+ +
diff --git a/examples/mig-example-apps/HtmlTemplate/templates/main.html b/examples/mig-example-apps/HtmlTemplate/templates/main.html new file mode 100644 index 0000000..f03ac87 --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/main.html @@ -0,0 +1,32 @@ + + + + + + + {{title}} + + + + + +
+
+
+
+ blog logo + +
+
+ {{{content}}} +
+
+
+
+ + + diff --git a/examples/mig-example-apps/HtmlTemplate/templates/post.html b/examples/mig-example-apps/HtmlTemplate/templates/post.html new file mode 100644 index 0000000..fb9b366 --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/post.html @@ -0,0 +1,5 @@ +
+

{{title}}

+

Created at: {{createdAt}}

+
{{content}}
+
diff --git a/examples/mig-example-apps/HtmlTemplate/templates/postNotFound.html b/examples/mig-example-apps/HtmlTemplate/templates/postNotFound.html new file mode 100644 index 0000000..7efb5c7 --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/postNotFound.html @@ -0,0 +1 @@ +

Post not found

diff --git a/examples/mig-example-apps/HtmlTemplate/templates/quote.html b/examples/mig-example-apps/HtmlTemplate/templates/quote.html new file mode 100644 index 0000000..738e8ef --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/quote.html @@ -0,0 +1,2 @@ +

Quote of the day:

+

{{content}}

diff --git a/examples/mig-example-apps/HtmlTemplate/templates/writeForm.html b/examples/mig-example-apps/HtmlTemplate/templates/writeForm.html new file mode 100644 index 0000000..1f0d8bb --- /dev/null +++ b/examples/mig-example-apps/HtmlTemplate/templates/writeForm.html @@ -0,0 +1,19 @@ +
+

Write new post

+ +
+
+

Input title

+ +
+ +
+

Input content

+ +
+ +
+ +
+
+
diff --git a/examples/mig-example-apps/README.md b/examples/mig-example-apps/README.md index b085e85..493e88b 100644 --- a/examples/mig-example-apps/README.md +++ b/examples/mig-example-apps/README.md @@ -13,6 +13,8 @@ We can find out how to build various servers: * `Html` - simple blog post site that servers HTML. +* `HtmlTemplate` - variation of `Html` example with safe URLs and HTML-templates + Also we can build clients: * `HelloClient` - basic hello world client diff --git a/examples/mig-example-apps/mig-example-apps.cabal b/examples/mig-example-apps/mig-example-apps.cabal index fccfba1..cc5572c 100644 --- a/examples/mig-example-apps/mig-example-apps.cabal +++ b/examples/mig-example-apps/mig-example-apps.cabal @@ -7,26 +7,30 @@ cabal-version: 1.12 name: mig-example-apps version: 0.1.0.0 description: Please see the README on GitHub at -homepage: https://github.com/githubuser/mig-example-apps#readme -bug-reports: https://github.com/githubuser/mig-example-apps/issues -author: Author name here -maintainer: example@example.com -copyright: 2023 Author name here +homepage: https://github.com/anton-k/mig#readme +bug-reports: https://github.com/anton-k/mig/issues +author: Anton Kholomiov +maintainer: anton.kholomiov@gmail.com +copyright: 2023 Anton Kholomiov license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md - Html/resources/haskell-logo.png - Html/resources/lambda-logo.png - Html/resources/milligram.min.css HtmlTemplate/resources/haskell-logo.png HtmlTemplate/resources/lambda-logo.png HtmlTemplate/resources/milligram.min.css + HtmlTemplate/templates/greeting.html + HtmlTemplate/templates/listPosts.html + HtmlTemplate/templates/main.html + HtmlTemplate/templates/post.html + HtmlTemplate/templates/postNotFound.html + HtmlTemplate/templates/quote.html + HtmlTemplate/templates/writeForm.html source-repository head type: git - location: https://github.com/githubuser/mig-example-apps + location: https://github.com/anton-k/mig executable counter-client-mig-example-app main-is: Main.hs @@ -61,7 +65,6 @@ executable counter-client-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-client , http-types , mig @@ -108,7 +111,6 @@ executable counter-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-types , mig , mig-client @@ -154,7 +156,6 @@ executable hello-world-client-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-client , http-types , mig @@ -200,7 +201,6 @@ executable hello-world-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-types , mig , mig-client @@ -253,7 +253,6 @@ executable html-mig-example-app , blaze-html , bytestring , containers - , derive-topdown , fast-logger , file-embed-lzma , http-api-data @@ -309,9 +308,9 @@ executable html-template-mig-example-app , aeson-pretty , base >=4.7 && <5 , blaze-html + , blaze-markup , bytestring , containers - , derive-topdown , fast-logger , file-embed-lzma , http-api-data @@ -325,6 +324,7 @@ executable html-template-mig-example-app , pretty-simple , random , safe + , stache , text , time , uuid @@ -366,7 +366,6 @@ executable json-api-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , fast-logger , http-types , mig @@ -413,7 +412,6 @@ executable route-args-client-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-client , http-types , mig @@ -459,7 +457,6 @@ executable route-args-mig-example-app , base >=4.7 && <5 , bytestring , containers - , derive-topdown , http-types , mig , mig-client diff --git a/examples/mig-example-apps/package.yaml b/examples/mig-example-apps/package.yaml index 2d80187..5fef2ac 100644 --- a/examples/mig-example-apps/package.yaml +++ b/examples/mig-example-apps/package.yaml @@ -1,15 +1,15 @@ name: mig-example-apps version: 0.1.0.0 -github: "githubuser/mig-example-apps" +github: "anton-k/mig" license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2023 Author name here" +author: "Anton Kholomiov" +maintainer: "anton.kholomiov@gmail.com" +copyright: "2023 Anton Kholomiov" extra-source-files: - README.md -- Html/resources/* - HtmlTemplate/resources/* +- HtmlTemplate/templates/* # Metadata used when publishing your package # synopsis: Short description of your package @@ -72,7 +72,6 @@ dependencies: - safe - containers - http-types - - derive-topdown executables: hello-world-mig-example-app: @@ -171,4 +170,6 @@ executables: - uuid - http-api-data - fast-logger + - stache + - blaze-markup diff --git a/mig-extra/src/Mig/Extra/Server/Html.hs b/mig-extra/src/Mig/Extra/Server/Html.hs index dfca8f6..8305d8f 100644 --- a/mig-extra/src/Mig/Extra/Server/Html.hs +++ b/mig-extra/src/Mig/Extra/Server/Html.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} -- | Html servers @@ -16,6 +17,9 @@ module Mig.Extra.Server.Html ( Resp (..), RespOr, + -- * utils + Link (..), + -- * re-exports Body (..), module X, @@ -24,6 +28,8 @@ module Mig.Extra.Server.Html ( import Mig.Core (Body (..)) import Mig.Core qualified as Core import Mig.Extra.Server.Common as X +import Text.Blaze.Html5 qualified as H +import Text.Blaze.Html5.Attributes qualified as HA -- response @@ -40,3 +46,16 @@ type Patch m a = Send PATCH m (Resp a) type Options m a = Send OPTIONS m (Resp a) type Head m a = Send HEAD m (Resp a) type Trace m a = Send TRACE m (Resp a) + +{-| HTML a-links, this type is useful for using +with template engines that rely on @ToJSON@ instance. +Also it can be rendered as Html with @ToMarkup@ instance. +-} +data Link = Link + { href :: Url + , name :: Text + } + deriving (Generic, ToJSON) + +instance ToMarkup Link where + toMarkup link = H.a H.! HA.href (renderUrl link.href) $ H.text link.name diff --git a/mig-extra/src/Mig/Extra/Server/Html/IO.hs b/mig-extra/src/Mig/Extra/Server/Html/IO.hs index 6850c3e..6d7a2b5 100644 --- a/mig-extra/src/Mig/Extra/Server/Html/IO.hs +++ b/mig-extra/src/Mig/Extra/Server/Html/IO.hs @@ -14,6 +14,9 @@ module Mig.Extra.Server.Html.IO ( Resp (..), RespOr, + -- * utils + Link (..), + -- * re-exports Body (..), module X, @@ -21,7 +24,7 @@ module Mig.Extra.Server.Html.IO ( import Mig.Core (Body (..)) import Mig.Extra.Server.Common as X -import Mig.Extra.Server.Html (Resp (..), RespOr) +import Mig.Extra.Server.Html (Link (..), Resp (..), RespOr) type Get a = Send GET IO (Resp a) type Post a = Send POST IO (Resp a) diff --git a/mig/src/Mig/Core/Class/Url.hs b/mig/src/Mig/Core/Class/Url.hs index bd661ec..c5f426a 100644 --- a/mig/src/Mig/Core/Class/Url.hs +++ b/mig/src/Mig/Core/Class/Url.hs @@ -5,6 +5,7 @@ module Mig.Core.Class.Url ( ToUrl (..), ) where +import Data.Aeson (ToJSON (..)) import Data.Bifunctor import Data.Kind import Data.Map.Strict (Map) @@ -31,6 +32,9 @@ data Url = Url -- ^ map of captures } +instance ToJSON Url where + toJSON = toJSON . renderUrl @Text + {-| Render URL to string-like value. TODO: use Text.Builder @@ -56,7 +60,18 @@ renderUrl url = -- | Converts route type to URL function type family UrlOf a :: Type where UrlOf (Send method m a) = Url - UrlOf (a -> b) = (a -> UrlOf b) + UrlOf (Query name value -> b) = (Query name value -> UrlOf b) + UrlOf (Optional name value -> b) = (Optional name value -> UrlOf b) + UrlOf (Capture name value -> b) = (Capture name value -> UrlOf b) + UrlOf (QueryFlag name -> b) = (QueryFlag name -> UrlOf b) + UrlOf (Header name value -> b) = UrlOf b + UrlOf (OptionalHeader name value -> b) = UrlOf b + UrlOf (Body media value -> b) = UrlOf b + UrlOf (Cookie value -> b) = UrlOf b + UrlOf (PathInfo -> b) = UrlOf b + UrlOf (FullPathInfo -> b) = UrlOf b + UrlOf (RawRequest -> b) = UrlOf b + UrlOf (IsSecure -> b) = UrlOf b UrlOf (a, b) = (UrlOf a, UrlOf b) UrlOf (a, b, c) = (UrlOf a, UrlOf b, UrlOf c) UrlOf (a, b, c, d) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d) @@ -118,6 +133,22 @@ instance (ToUrl a, ToUrl b) => ToUrl (a, b) where mapUrl f (a, b) = (mapUrl f a, mapUrl f b) urlArity = urlArity @a + urlArity @b +instance (ToUrl a, ToUrl b, ToUrl c) => ToUrl (a, b, c) where + toUrl server = fromPair $ toUrl @(a, (b, c)) server + where + fromPair (a, (b, c)) = (a, b, c) + + mapUrl f (a, b, c) = (mapUrl f a, mapUrl f b, mapUrl f c) + urlArity = urlArity @a + urlArity @b + urlArity @c + +instance (ToUrl a, ToUrl b, ToUrl c, ToUrl d) => ToUrl (a, b, c, d) where + toUrl server = fromPair $ toUrl @(a, (b, c, d)) server + where + fromPair (a, (b, c, d)) = (a, b, c, d) + + mapUrl f (a, b, c, d) = (mapUrl f a, mapUrl f b, mapUrl f c, mapUrl f d) + urlArity = urlArity @a + urlArity @b + urlArity @c + urlArity @d + instance ToUrl Url where toUrl server = case getServerPaths server of url : _ -> Url url [] mempty @@ -168,58 +199,6 @@ instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Capture sym a -> insertCapture :: Text -> Text -> Url -> Url insertCapture name val url = url{captures = Map.insert name val url.captures} --- body - -instance (ToUrl b) => ToUrl (Body media a -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \body -> mapUrl f (a body) - urlArity = urlArity @b - --- header - -instance (ToUrl b) => ToUrl (Header sym a -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \header -> mapUrl f (a header) - urlArity = urlArity @b - --- optional header - -instance (ToUrl b) => ToUrl (OptionalHeader sym a -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \header -> mapUrl f (a header) - urlArity = urlArity @b - --- cookie - -instance (ToUrl b) => ToUrl (Cookie a -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \header -> mapUrl f (a header) - urlArity = urlArity @b - --- path info -instance (ToUrl b) => ToUrl (PathInfo -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \input -> mapUrl f (a input) - urlArity = urlArity @b - --- full path info -instance (ToUrl b) => ToUrl (FullPathInfo -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \input -> mapUrl f (a input) - urlArity = urlArity @b - --- request -instance (ToUrl b) => ToUrl (RawRequest -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \input -> mapUrl f (a input) - urlArity = urlArity @b - --- is secure -instance (ToUrl b) => ToUrl (IsSecure -> b) where - toUrl server = const $ toUrl @b server - mapUrl f a = \input -> mapUrl f (a input) - urlArity = urlArity @b - ------------------------------------------------------------------------------------- -- utils