diff --git a/IHP/SEO/Sitemap/ControllerFunctions.hs b/IHP/SEO/Sitemap/ControllerFunctions.hs new file mode 100644 --- /dev/null +++ b/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, ?request :: Request) => Sitemap -> IO () +renderXmlSitemap Sitemap { links } = do + let sitemap = Markup.toMarkup [xmlDocument, sitemapLinks] + renderXml $ Markup.renderMarkup sitemap + where + xmlDocument = Markup.preEscapedText "" + 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) diff --git a/IHP/SEO/Sitemap/Routes.hs b/IHP/SEO/Sitemap/Routes.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/IHP/SEO/Sitemap/Types.hs b/IHP/SEO/Sitemap/Types.hs new file mode 100644 --- /dev/null +++ b/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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Test/SEO/Sitemap.hs b/Test/SEO/Sitemap.hs new file mode 100644 --- /dev/null +++ b/Test/SEO/Sitemap.hs @@ -0,0 +1,80 @@ +module Main where + +import Test.Hspec +import IHP.Test.Mocking +import IHP.Environment +import IHP.ViewPrelude +import IHP.ControllerPrelude hiding (get, request) +import Network.Wai.Test +import Network.HTTP.Types + +import IHP.SEO.Sitemap.Types +import IHP.SEO.Sitemap.Routes () +import IHP.SEO.Sitemap.ControllerFunctions + +main :: IO () +main = hspec do + tests + +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 (post.id) + , lastModified = Just (post.updatedAt) + , changeFrequency = Just Hourly + }) + renderXmlSitemap (Sitemap sitemapLinks) + +data WebApplication + = WebApplication + deriving (Eq, Show, Data) + +instance FrontController WebApplication where + controllers = [ parseRoute @SitemapController ] + +instance InitControllerContext WebApplication where + initContext = pure () + +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 + response.simpleStatus `shouldBe` status200 + response.simpleBody `shouldBe` (cs body) + +assertFailure :: SResponse -> IO () +assertFailure response = do + response.simpleStatus `shouldBe` status400 + +config = do + option Development + option (AppPort 8000) + +tests :: Spec +tests = aroundAll (withMockContextAndApp WebApplication config) do + describe "SEO" do + describe "Sitemap" do + it "should render a XML Sitemap" $ withContextAndApp \application -> do + runSession (testGet "/sitemap.xml") application + >>= assertSuccess "http://localhost:8000/main/ShowPost?postId=00000000-0000-0000-0000-0000000000002105-04-16hourly" diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,5 @@ +# Changelog for `ihp-sitemap` + +## v1.5.0 + +- No user-facing changes since 1.4.0 diff --git a/ihp-sitemap.cabal b/ihp-sitemap.cabal new file mode 100644 --- /dev/null +++ b/ihp-sitemap.cabal @@ -0,0 +1,68 @@ +cabal-version: 2.2 +name: ihp-sitemap +version: 1.5.0 +synopsis: SEO +description: Render sitemaps with IHP +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: support@digitallyinduced.com +homepage: https://ihp.digitallyinduced.com/ +bug-reports: https://github.com/digitallyinduced/ihp/issues +copyright: (c) digitally induced GmbH +category: SEO +build-type: Simple +extra-source-files: changelog.md + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp.git + +common ihp-std + default-language: GHC2021 + default-extensions: + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + DuplicateRecordFields + DisambiguateRecordFields + TypeApplications + TemplateHaskell + QuasiQuotes + PackageImports + ScopedTypeVariables + BlockArguments + OverloadedStrings + ImplicitParams + ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields + +library + import: ihp-std + build-depends: + base >= 4.17.0 && < 4.22 + , text + , ihp + , blaze-html + , blaze-markup + , wai + hs-source-dirs: . + exposed-modules: + IHP.SEO.Sitemap.ControllerFunctions + , IHP.SEO.Sitemap.Routes + , IHP.SEO.Sitemap.Types + +test-suite tests + import: ihp-std + type: exitcode-stdio-1.0 + main-is: SEO/Sitemap.hs + build-depends: + base >= 4.17.0 && < 4.22 + , hspec + , ihp + , ihp-sitemap + , wai + , wai-extra + , http-types + , ihp-hsx + , ihp-log + hs-source-dirs: Test