Skip to content

Commit

Permalink
Implements html example with templates
Browse files Browse the repository at this point in the history
anton-k committed Nov 22, 2023

Verified

This commit was created on GitHub.com and signed with GitHub’s verified signature. The key has expired.
1 parent cab0309 commit d6fe05f
Showing 18 changed files with 295 additions and 154 deletions.
2 changes: 1 addition & 1 deletion examples/mig-example-apps/HtmlTemplate/src/Init.hs
Original file line number Diff line number Diff line change
@@ -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
2 changes: 1 addition & 1 deletion examples/mig-example-apps/HtmlTemplate/src/Interface.hs
Original file line number Diff line number Diff line change
@@ -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 ()
22 changes: 11 additions & 11 deletions examples/mig-example-apps/HtmlTemplate/src/Server.hs
Original file line number Diff line number Diff line change
@@ -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
33 changes: 26 additions & 7 deletions examples/mig-example-apps/HtmlTemplate/src/Types.hs
Original file line number Diff line number Diff line change
@@ -7,6 +7,8 @@ module Types (
BlogPostId (..),
BlogPostView (..),
BlogPost (..),
BlogPostLink (..),
toBlogPostLink,
Quote (..),
SubmitBlogPost (..),
) where
@@ -18,35 +20,53 @@ 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
, title :: Text
, 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
158 changes: 88 additions & 70 deletions examples/mig-example-apps/HtmlTemplate/src/View.hs
Original file line number Diff line number Diff line change
@@ -1,103 +1,121 @@
{-# 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)

data Templates = Templates
{ main :: Template
, greeting :: Template
, post :: Template
, quote :: Template
, writeForm :: Template
, listPosts :: Template
, postNotFound :: Template
}

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
}
14 changes: 14 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/greeting.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,14 @@
<div>
<h2> Welcome to blog site example </h2>
<p> You can get random poem or random quote from menu bar </p>
<div>
<h2> Posts: </h2>
<ul>
{{#posts}}
<li>
<a href="{{href}}"> {{name}} </a>
</li>
{{/posts}}
</ul>
</div>
</div>
10 changes: 10 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/listPosts.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@
<div>
<h2> Posts: </h2>
<ul>
{{#posts}}
<li>
<a href="{{href}}"> {{name}} </a>
</li>
{{/posts}}
</ul>
</div>
32 changes: 32 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/main.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,32 @@
<!DOCTYPE html>
<html lang="en">

<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>{{title}}</title>
<link rel="stylesheet" href="https://fonts.googleapis.com/css?family=Roboto:300,300italic,700,700italic">
<link rel="stylesheet" href="/static/milligram.min.css">
</head>

<body>
<div style="margin-left:4%; margin-top: 3%; font-size: 110%">
<div class="container">
<div class="row">
<div class="column column-20">
<img src= "/static/haskell-logo.png" alt="blog logo" width="100pt" style="margin-bottom: 15pt">
<ul style="list-style: none">
{{#menuLinks}}
<li> <a href="{{href}}"> {{name}} </a></li>
{{/menuLinks}}
</ul>
</div>
<div class="column column-75 column-offset-5">
{{{content}}}
</div>
</div>
</div>
</div>
</body>

</html>
5 changes: 5 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/post.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
<div>
<div> <h2> {{title}} </h2> </div>
<div> <p> Created at: {{createdAt}} </p> </div>
<div style="white-space: pre-wrap"> {{content}} </div>
</div>
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
<p> Post not found </p>
2 changes: 2 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/quote.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
<div> <h2> Quote of the day: </h2> </div>
<div> <p> {{content}} </p> </div>
19 changes: 19 additions & 0 deletions examples/mig-example-apps/HtmlTemplate/templates/writeForm.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,19 @@
<div>
<h2> Write new post </h2>

<form method="POST" action="{{href}}">
<div>
<p> Input title </p>
<textarea rows="1" cols="100" id="title" name="title"> </textarea>
</div>

<div>
<p> Input content </p>
<textarea rows="50" cols="100" id="content" name="content"> </textarea>
</div>

<div>
<input type="submit" value="Save blog post"/>
</div>
</form>
</div>
2 changes: 2 additions & 0 deletions examples/mig-example-apps/README.md
Original file line number Diff line number Diff line change
@@ -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
34 changes: 25 additions & 9 deletions examples/mig-example-apps/mig-example-apps.cabal
Original file line number Diff line number Diff line change
@@ -23,6 +23,13 @@ extra-source-files:
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
@@ -59,9 +66,9 @@ executable counter-client-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-client
, http-types
, mig
@@ -74,6 +81,7 @@ executable counter-client-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
@@ -106,9 +114,9 @@ executable counter-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-types
, mig
, mig-client
@@ -120,6 +128,7 @@ executable counter-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
@@ -152,9 +161,9 @@ executable hello-world-client-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-client
, http-types
, mig
@@ -166,6 +175,7 @@ executable hello-world-client-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
@@ -198,9 +208,9 @@ executable hello-world-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-types
, mig
, mig-client
@@ -211,6 +221,7 @@ executable hello-world-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
@@ -251,9 +262,9 @@ executable html-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
@@ -267,6 +278,7 @@ executable html-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
, uuid
@@ -309,9 +321,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 +337,7 @@ executable html-template-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
, uuid
@@ -364,9 +377,9 @@ executable json-api-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, fast-logger
, http-types
, mig
@@ -378,6 +391,7 @@ executable json-api-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
, yaml
@@ -411,9 +425,9 @@ executable route-args-client-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-client
, http-types
, mig
@@ -425,6 +439,7 @@ executable route-args-client-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
@@ -457,9 +472,9 @@ executable route-args-mig-example-app
aeson
, aeson-pretty
, base >=4.7 && <5
, blaze-markup
, bytestring
, containers
, derive-topdown
, http-types
, mig
, mig-client
@@ -470,6 +485,7 @@ executable route-args-mig-example-app
, pretty-simple
, random
, safe
, stache
, text
, time
default-language: GHC2021
4 changes: 3 additions & 1 deletion examples/mig-example-apps/package.yaml
Original file line number Diff line number Diff line change
@@ -10,6 +10,7 @@ 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 +73,8 @@ dependencies:
- safe
- containers
- http-types
- derive-topdown
- stache
- blaze-markup

executables:
hello-world-mig-example-app:
19 changes: 19 additions & 0 deletions mig-extra/src/Mig/Extra/Server/Html.hs
Original file line number Diff line number Diff line change
@@ -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
5 changes: 4 additions & 1 deletion mig-extra/src/Mig/Extra/Server/Html/IO.hs
Original file line number Diff line number Diff line change
@@ -14,14 +14,17 @@ module Mig.Extra.Server.Html.IO (
Resp (..),
RespOr,

-- * utils
Link (..),

-- * re-exports
Body (..),
module X,
) where

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)
85 changes: 32 additions & 53 deletions mig/src/Mig/Core/Class/Url.hs
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit d6fe05f

Please sign in to comment.