Merge pull request #1431 from digitallyinduced/s0kil/fix-issue-1430

Sitemap Generator

Guide/Makefile

@@ -49,6 +49,7 @@ HTML_FILES+= examples.html
 HTML_FILES+= stripe.html
 HTML_FILES+= realtime-spas.html
 HTML_FILES+= config.html
+HTML_FILES+= seo.html
 
 all: $(HTML_FILES) bootstrap.css instantclick.js search.js search.css
 
@@ -79,4 +80,4 @@ search.css: search/node_modules
 	./search/node_modules/.bin/esbuild search/node_modules/@docsearch/css/dist/style.css --minify-whitespace --outfile=search.css
 
 guide.tar.gz: all
-	tar -czvf guide.tar.gz *.html *.css *.js images/* images/*/*
+	tar -czvf guide.tar.gz *.html *.css *.js images/* images/*/*

Guide/layout.html

@@ -95,6 +95,8 @@
                 <a class="nav-link secondary" href="authorization.html">Authorization</a>
                 <a class="nav-link secondary" href="oauth.html">OAuth</a>
 
+                <a class="nav-link headline" href="seo.html">SEO</a>
+
                 <a class="nav-link headline" href="recipes.html">Recipes</a>
                 <a class="nav-link headline" href="troubleshooting.html">Troubleshooting</a>
 

Guide/seo.markdown

@@ -0,0 +1,84 @@
+# SEO
+
+```toc
+
+```
+
+## Sitemap
+
+Generating an XML Sitemap (`/sitemap.xml`)
+
+First we create a new controller file: `Web/Controller/Sitemap.hs` with the following contents:
+
+```haskell
+module Web.Controller.Sitemap where
+
+import Web.Controller.Prelude
+import IHP.SEO.Sitemap.Types
+import IHP.SEO.Sitemap.ControllerFunctions
+
+instance Controller SitemapController where
+    action SitemapAction = do
+        -- Query all the posts
+        posts <- query @Post |> fetch
+        -- Build an `SitemapLink` for all posts
+        let sitemapLinks = posts |> map (\post ->
+                SitemapLink
+                    { url = urlTo $ ShowPostAction (get #id post)
+                    , lastModified = Nothing
+                    , changeFrequency = Just Hourly
+                    })
+        -- Render The Sitemap
+        renderXmlSitemap (Sitemap sitemapLinks)
+
+```
+
+In your `Web/Routes.hs` module, import the `IHP.SEO.Sitemap.Routes` module:
+
+```haskell
+module Web.Routes where
+...
+import IHP.SEO.Sitemap.Routes
+...
+```
+
+Next, import the `IHP.SEO.Sitemap.Types` module in `Web/FrontController.hs`:
+
+```haskell
+module Web.FrontController where
+...
+import IHP.SEO.Sitemap.Types
+...
+```
+
+And then add `parseRoute @SitemapController`:
+
+```haskell
+instance FrontController WebApplication where
+    controllers =
+        [ startPage WelcomeAction
+        , parseRoute @SitemapController -- Add This Line
+        -- Generator Marker
+        ]
+```
+
+The `SitemapController` is configured by default to resolve `/sitemap.xml` routes.
+If you need to customize the route, first, remove the `IHP.SEO.Sitemap.Routes` import from the `Web.Routes` module.
+And add the following:
+
+```haskell
+module Web.Routes where
+...
+import IHP.SEO.Sitemap.Types -- Import The `SitemapController` Type
+...
+
+-- Here we customize the resolved route as `/custom-sitemap.xml`
+instance HasPath SitemapController where
+    pathTo SitemapAction = "/custom-sitemap.xml"
+
+instance CanRoute SitemapController where
+    parseRoute' = do
+        string "/custom-sitemap.xml"
+        endOfInput
+        pure SitemapAction
+```

IHP/SEO/Sitemap/ControllerFunctions.hs

@@ -0,0 +1,27 @@
+module IHP.SEO.Sitemap.ControllerFunctions where
+
+import IHP.Prelude
+import IHP.ControllerPrelude
+import IHP.SEO.Sitemap.Types
+import qualified Text.Blaze as Markup
+import qualified Text.Blaze.Internal as Markup
+import qualified Text.Blaze.Renderer.Utf8 as Markup
+
+renderXmlSitemap :: (?context::ControllerContext) => Sitemap -> IO ()
+renderXmlSitemap Sitemap { links } = do
+    let sitemap = Markup.toMarkup [xmlDocument, sitemapLinks]
+    renderXml $ Markup.renderMarkup sitemap
+    where
+        xmlDocument = Markup.preEscapedText "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+        urlSet = Markup.customParent "urlset" Markup.! Markup.customAttribute "xmlns" "http://www.sitemaps.org/schemas/sitemap/0.9"
+        sitemapLinks = urlSet (Markup.toMarkup (map sitemapLink links))
+        sitemapLink SitemapLink { url, lastModified, changeFrequency } =
+            let
+                loc = Markup.customParent "loc" (Markup.text url)
+                lastMod =  Markup.customParent "lastmod" (Markup.text (maybe mempty formatUTCTime lastModified))
+                changeFreq = Markup.customParent "changefreq" (Markup.text (maybe mempty show changeFrequency))
+            in
+                Markup.customParent "url" (Markup.toMarkup [loc, lastMod, changeFreq])
+
+formatUTCTime :: UTCTime -> Text
+formatUTCTime utcTime = cs (formatTime defaultTimeLocale "%Y-%m-%d" utcTime)

IHP/SEO/Sitemap/Routes.hs

@@ -0,0 +1,14 @@
+module IHP.SEO.Sitemap.Routes where
+
+import IHP.Prelude
+import IHP.RouterPrelude
+import IHP.SEO.Sitemap.Types
+
+instance HasPath SitemapController where
+    pathTo SitemapAction = "/sitemap.xml"
+
+instance CanRoute SitemapController where
+    parseRoute' = do
+        string "/sitemap.xml"
+        endOfInput
+        pure SitemapAction

IHP/SEO/Sitemap/Types.hs

@@ -0,0 +1,41 @@
+module IHP.SEO.Sitemap.Types
+( SitemapController(..)
+, Sitemap(..)
+, SitemapLink(..)
+, SitemapChangeFrequency(..)
+)
+where
+
+import IHP.Prelude
+import Prelude (Show(..))
+
+data SitemapController
+    = SitemapAction
+    deriving (Eq, Show, Data)
+
+data Sitemap
+    = Sitemap { links :: [SitemapLink] }
+    deriving (Eq, Show, Data)
+
+data SitemapLink
+    = SitemapLink { url :: Text, lastModified :: Maybe UTCTime, changeFrequency :: Maybe SitemapChangeFrequency }
+    deriving (Eq, Show, Data)
+
+data SitemapChangeFrequency
+    = Always
+    | Hourly
+    | Daily
+    | Weekly
+    | Monthly
+    | Yearly
+    | Never
+    deriving (Eq, Data)
+
+instance Show SitemapChangeFrequency where
+    show Always = "always"
+    show Hourly = "hourly"
+    show Daily = "daily"
+    show Weekly = "weekly"
+    show Monthly = "monthly"
+    show Yearly = "yearly"
+    show Never = "never"

Test/Main.hs

@@ -52,6 +52,7 @@ import qualified Test.PGListenerSpec
 import qualified Test.GraphQL.ParserSpec
 import qualified Test.GraphQL.CompilerSpec
 import qualified Test.GraphQL.SchemaCompilerSpec
+import qualified Test.SEO.Sitemap
 
 main :: IO ()
 main = hspec do
@@ -90,4 +91,5 @@ main = hspec do
     Test.PGListenerSpec.tests
     Test.GraphQL.ParserSpec.tests
     Test.GraphQL.CompilerSpec.tests
-    Test.GraphQL.SchemaCompilerSpec.tests
+    Test.GraphQL.SchemaCompilerSpec.tests
+    Test.SEO.Sitemap.tests

Test/SEO/Sitemap.hs

@@ -0,0 +1,82 @@
+module Test.SEO.Sitemap where
+
+import Test.Hspec
+import IHP.Test.Mocking
+import IHP.Environment
+import IHP.ViewPrelude
+import IHP.ControllerPrelude hiding (get, request)
+import qualified IHP.Server as Server
+import Network.Wai
+import Network.Wai.Test
+import Network.HTTP.Types
+
+import IHP.SEO.Sitemap.Types
+import IHP.SEO.Sitemap.Routes
+import IHP.SEO.Sitemap.ControllerFunctions
+
+data Post = Post
+        { id :: UUID
+        , updatedAt :: UTCTime
+        }
+
+data PostController
+  = ShowPostAction { postId :: UUID }
+  deriving (Eq, Show, Data)
+
+instance AutoRoute PostController
+
+instance Controller SitemapController where
+    action SitemapAction = do
+        let time = UTCTime { utctDay = ModifiedJulianDay (300 * 300), utctDayTime = 300 * 300 }
+        let posts = [Post { id = def, updatedAt = time }]
+        let sitemapLinks = posts |> map (\post ->
+                SitemapLink
+                    { url = urlTo $ ShowPostAction (get #id post)
+                    , lastModified = Just (get #updatedAt post)
+                    , changeFrequency = Just Hourly
+                    })
+        renderXmlSitemap (Sitemap sitemapLinks)
+
+data WebApplication
+    = WebApplication
+    deriving (Eq, Show, Data)
+
+instance FrontController WebApplication where
+  controllers = [ parseRoute @SitemapController ]
+
+defaultLayout :: Html -> Html
+defaultLayout inner =  [hsx|{inner}|]
+
+instance InitControllerContext WebApplication where
+  initContext = do
+    setLayout defaultLayout
+
+instance FrontController RootApplication where
+    controllers = [ mountFrontController WebApplication ]
+
+instance Worker RootApplication where
+    workers _ = []
+
+testGet :: ByteString -> Session SResponse
+testGet url = request $ setPath defaultRequest { requestMethod = methodGet } url
+
+assertSuccess :: ByteString -> SResponse -> IO ()
+assertSuccess body response = do
+    get #simpleStatus response `shouldBe` status200
+    get #simpleBody response `shouldBe` (cs body)
+
+assertFailure :: SResponse -> IO ()
+assertFailure response = do
+    get #simpleStatus response `shouldBe` status400
+
+config = do
+    option Development
+    option (AppPort 8000)
+
+tests :: Spec
+tests = beforeAll (mockContextNoDatabase WebApplication config) do
+    describe "SEO" do
+        describe "Sitemap" do
+            it "should render a XML Sitemap" $ withContext do
+                runSession (testGet "/sitemap.xml") Server.application
+                    >>= assertSuccess "<?xml version=\"1.0\" encoding=\"UTF-8\"?><urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\"><url><loc>http://localhost:8000/test/ShowPost?postId=00000000-0000-0000-0000-000000000000</loc><lastmod>2105-04-16</lastmod><changefreq>hourly</changefreq></url></urlset>"

ihp.cabal

@@ -381,6 +381,9 @@ library
         , IHP.GraphQL.SchemaCompiler
         , IHP.GraphQL.ToText
         , IHP.GraphQL.Types
+        , IHP.SEO.Sitemap.Types
+        , IHP.SEO.Sitemap.ControllerFunctions
+        , IHP.SEO.Sitemap.Routes
 
 executable RunDevServer
     import: shared-properties