ihp-sitemap (empty) → 1.5.0
raw patch · 7 files changed
+256/−0 lines, 7 filesdep +basedep +blaze-htmldep +blaze-markup
Dependencies added: base, blaze-html, blaze-markup, hspec, http-types, ihp, ihp-hsx, ihp-log, ihp-sitemap, text, wai, wai-extra
Files
- IHP/SEO/Sitemap/ControllerFunctions.hs +27/−0
- IHP/SEO/Sitemap/Routes.hs +14/−0
- IHP/SEO/Sitemap/Types.hs +41/−0
- LICENSE +21/−0
- Test/SEO/Sitemap.hs +80/−0
- changelog.md +5/−0
- ihp-sitemap.cabal +68/−0
+ IHP/SEO/Sitemap/ControllerFunctions.hs view
@@ -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 "<?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 view
@@ -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 view
@@ -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"
+ LICENSE view
@@ -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.
+ Test/SEO/Sitemap.hs view
@@ -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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?><urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\"><url><loc>http://localhost:8000/main/ShowPost?postId=00000000-0000-0000-0000-000000000000</loc><lastmod>2105-04-16</lastmod><changefreq>hourly</changefreq></url></urlset>"
+ changelog.md view
@@ -0,0 +1,5 @@+# Changelog for `ihp-sitemap`++## v1.5.0++- No user-facing changes since 1.4.0
+ ihp-sitemap.cabal view
@@ -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