Merge pull request #78 from anton-k/improve-urls

Implements html example with templates

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

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 ()

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

examples/mig-example-apps/HtmlTemplate/src/Types.hs

@@ -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

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
+        }

examples/mig-example-apps/HtmlTemplate/templates/greeting.html

@@ -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>

examples/mig-example-apps/HtmlTemplate/templates/listPosts.html

@@ -0,0 +1,10 @@
+<div> 
+  <h2> Posts: </h2>
+  <ul>
+    {{#posts}}
+    <li>
+      <a href="{{href}}"> {{name}} </a>
+    </li>
+    {{/posts}}
+  </ul>
+</div>

examples/mig-example-apps/HtmlTemplate/templates/main.html

@@ -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>

examples/mig-example-apps/HtmlTemplate/templates/post.html

@@ -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>

examples/mig-example-apps/HtmlTemplate/templates/postNotFound.html

@@ -0,0 +1 @@
+<p> Post not found </p>