diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# CHANGELOG + +# v0.1.0.0 + +* Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Pavan Rikhi (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Pavan Rikhi nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# sitemap-gen + +[![sitemap-gen Build Status](https://travis-ci.org/prikhi/sitemap-gen.svg?branch=master)](https://travis-ci.org/prikhi/sitemap-gen) + + +`sitemap-gen` is a Haskell library for generating XML sitemaps and sitemap +index files. + +It uses the [xmlgen][xmlgen] library to generate XML that conforms to the +[sitemaps.org][sitemap-schema] XML schema. + +To use this library, build a `Sitemap` or `SitemapIndex` type and use the +respective `render...` functions to build the `ByteString` output: + +```haskell +import Web.Sitemap.Gen (Sitemap(..), SitemapUrl(..), renderSitemap) + +import qualified Data.ByteString as BS +import qualified Web.Sitemap.Gen as Sitemap + +mySitemap :: BS.ByteString +mySitemap = + let urls = + [ SitemapUrl + { sitemapLocation = "https://mydomain.com/my/url/" + , sitemapLastModified = Nothing + , sitemapChangeFrequency = Just Sitemap.Monthly + , sitemapPriority = Just 0.9 + } + , SitemapUrl + { sitemapLocation = "https://mydomain.com/lower/priority/" + , sitemapLastModified = Nothing + , sitemapChangeFrequency = Just Sitemap.Yearly + , sitemapPriority = Just 0.4 + } + ] + in + renderSitemap $ Sitemap urls +``` + + +## License + +BSD-3, exceptions possible. + + +[xmlgen]: https://hackage.haskell.org/package/xmlgen +[sitemap-schema]: https://www.sitemaps.org/protocol.html#index diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sitemap-gen.cabal b/sitemap-gen.cabal new file mode 100644 --- /dev/null +++ b/sitemap-gen.cabal @@ -0,0 +1,67 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 716f09635864c14167c214bde14ad690b83bc22197a791b6d89dd6f9fe46ccf5 + +name: sitemap-gen +version: 0.1.0.0 +synopsis: Generate XML Sitemaps & Sitemap Indexes +description: The @sitemap-gen@ package uses the @xmlgen@ package to generate XML + sitemaps that are compliant with the sitemaps.org XML schema. + . + See the "Web.Sitemap.Gen" module and the + file + for documentation & usage details. +category: Web +homepage: https://github.com/prikhi/sitemap-gen#readme +bug-reports: https://github.com/prikhi/sitemap-gen/issues +author: Pavan Rikhi +maintainer: pavan.rikhi@gmail.com +copyright: 2019 Pavan Rikhi +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/prikhi/sitemap-gen + +library + exposed-modules: + Web.Sitemap.Gen + other-modules: + Paths_sitemap_gen + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , text >=1 && <2 + , time >=1.6 && <2 + , xmlgen >=0.6 && <1 + default-language: Haskell2010 + +test-suite sitemap-gen-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_sitemap_gen + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , base >=4.7 && <5 + , bytestring + , raw-strings-qq + , sitemap-gen + , tasty + , tasty-hunit + , time + default-language: Haskell2010 diff --git a/src/Web/Sitemap/Gen.hs b/src/Web/Sitemap/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sitemap/Gen.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| The @Web.Sitemap.Gen@ module contains types & rendering functions +to generate XML compliant with the sitemaps.org specification. + +For more information see https://www.sitemaps.org/protocol.html + +-} +module Web.Sitemap.Gen + ( -- * Sitemaps + Sitemap(..) + , renderSitemap + , SitemapUrl(..) + , renderSitemapUrl + , ChangeFrequency(..) + , renderChangeFrequency + -- * Sitemap Indexes + , SitemapIndex(..) + , renderSitemapIndex + , IndexEntry(..) + , renderIndexEntry + -- * Utilities + , sitemapNamespace + , formatSitemapTime + , renderLastModified + ) +where + +import Data.Maybe ( catMaybes ) +import Data.Time ( UTCTime + , formatTime + , defaultTimeLocale + ) +import GHC.Generics ( Generic ) +import Text.XML.Generator ( Xml + , Elem + , XmlOutput + , Namespace + , xrender + , doc + , defaultDocInfo + , xelemQ + , namespace + , xelems + , xelemWithText + , xtext + , xelem + ) + +import qualified Data.Text as T + + +-- SITEMAPS + + +-- | A 'Sitemap' contains multiple 'SitemapUrl' elements which describe +-- crawlable locations for search engines. +newtype Sitemap = + Sitemap + { sitemapUrls :: [SitemapUrl] + } deriving (Show, Read, Eq, Generic) + +-- | Render a Sitemap into a output format supported by the @xmlgen@ package. +-- +-- In most cases you will want to generate a @ByteString@. +renderSitemap :: XmlOutput x => Sitemap -> x +renderSitemap sitemap = + xrender + $ doc defaultDocInfo + $ xelemQ sitemapNamespace "urlset" + $ xelems + $ map renderSitemapUrl + $ sitemapUrls sitemap + +-- | A 'SitemapUrl' describes a single URL in a 'Sitemap'. +data SitemapUrl = + SitemapUrl + { sitemapLocation :: T.Text + -- ^ The full URL of the page, including the protocol and + -- domain name. + , sitemapLastModified :: Maybe UTCTime + -- ^ The time the page's content was last changed. + , sitemapChangeFrequency :: Maybe ChangeFrequency + -- ^ How often does the content at the URL change? + , sitemapPriority :: Maybe Double + -- ^ The relative priority of this URL compared to other URLs in + -- the sitemap. + } deriving (Show, Read, Eq, Generic) + +-- | Render a 'SitemapUrl' as a @url@ XML element. +renderSitemapUrl :: SitemapUrl -> Xml Elem +renderSitemapUrl url = xelem "url" $ xelems $ catMaybes + [ Just $ xelemWithText "loc" $ sitemapLocation url + , renderLastModified <$> sitemapLastModified url + , xelem "changefreq" . renderChangeFrequency <$> sitemapChangeFrequency url + , xelemWithText "priority" . T.pack . show <$> sitemapPriority url + ] + +-- | Describes how often a SitemapUrl' is updated. This is considered +-- a hint for crawlers and may or may not be respected. +data ChangeFrequency + = Always + -- ^ The page changes every time it is visited. + | Hourly + | Daily + | Weekly + | Monthly + | Yearly + | Never + -- ^ The page is archived and will never change from now on. + deriving (Show, Read, Eq, Enum, Bounded, Generic) + +-- | Build the XML text content for a 'ChangeFrequency'. +renderChangeFrequency :: ChangeFrequency -> Xml Elem +renderChangeFrequency = xtext . \case + Always -> "always" + Hourly -> "hourly" + Daily -> "daily" + Weekly -> "weekly" + Monthly -> "monthly" + Yearly -> "yearly" + Never -> "never" + + +-- INDEXES + + +-- | A 'SitemapIndex' allows informing crawlers of multiple sitemap files +-- hosted on the same domain. +-- +-- See https://www.sitemaps.org/protocol.html#index +newtype SitemapIndex = + SitemapIndex + { indexEntries :: [IndexEntry] + } deriving (Show, Read, Eq, Generic) + + +-- | Render a 'SitemapIndex' into an output format supported by the +-- @xmlgen@ package. +renderSitemapIndex :: XmlOutput x => SitemapIndex -> x +renderSitemapIndex index = + xrender + $ doc defaultDocInfo + $ xelemQ sitemapNamespace "sitemapindex" + $ xelems + $ map renderIndexEntry + $ indexEntries index + +-- | A single sitemap entry for a sitemap index. +data IndexEntry = + IndexEntry + { indexLocation :: T.Text + -- ^ The Full URL of a Sitemap, including the protocol. + -- + -- E.g., @https://www.southernexposure.com/sitemap.xml@ + , indexLastModified :: Maybe UTCTime + -- ^ The time the sitemap was last changed. + } deriving (Show, Read, Eq, Generic) + +-- | Render an 'IndexEntry' as a @sitemap@ element. +renderIndexEntry :: IndexEntry -> Xml Elem +renderIndexEntry entry = xelem "sitemap" $ xelems $ catMaybes + [ Just $ xelemWithText "loc" $ indexLocation entry + , renderLastModified <$> indexLastModified entry + ] + + +-- UTILS + + +-- | An XML Namespace for the sitemaps.org @v0.9@ schema. +sitemapNamespace :: Namespace +sitemapNamespace = namespace "" "http://www.sitemaps.org/schemas/sitemap/0.9" + +-- | Render the 'UTCTime' in @YYYY-MM-DDTHH:MM:SS+00:00@ format. +formatSitemapTime :: UTCTime -> T.Text +formatSitemapTime = T.pack . formatTime defaultTimeLocale "%FT%T+00:00" + +-- | Render a 'UTCTime' in a @lastmod@ element. +renderLastModified :: UTCTime -> Xml Elem +renderLastModified = xelemWithText "lastmod" . formatSitemapTime diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +import Data.Time +import Test.Tasty +import Test.Tasty.HUnit hiding ( assert ) +import Text.RawString.QQ ( r ) + +import Web.Sitemap.Gen + +import qualified Data.ByteString as BS + + +main :: IO () +main = defaultMain tests + + +tests :: TestTree +tests = testGroup + "sitemap.org Examples" + [ testCase "Single Url Sitemap" singleUrlSitemap + , testCase "Multiple Url Sitemap" multipleUrlSitemap + , testCase "Sitemap Index" sitemapIndex + ] + + +singleUrlSitemap :: Assertion +singleUrlSitemap = + let + rendered = renderSitemap $ Sitemap + [ SitemapUrl + { sitemapLocation = "http://www.example.com/" + , sitemapPriority = Just 0.8 + , sitemapChangeFrequency = Just Monthly + , sitemapLastModified = Just $ UTCTime + (fromGregorian 2005 01 01) + 0 + } + ] + in singleUrlSitemapFixture @=? rendered + + + +singleUrlSitemapFixture :: BS.ByteString +singleUrlSitemapFixture = + [r| +http://www.example.com/2005-01-01T00:00:00+00:00monthly0.8|] + + +multipleUrlSitemap :: Assertion +multipleUrlSitemap = + let + urls = + [ SitemapUrl "http://www.example.com/" + (Just $ UTCTime (fromGregorian 2005 01 01) 0) + (Just Monthly) + (Just 0.8) + , SitemapUrl + "http://www.example.com/catalog?item=12&desc=vacation_hawaii" + Nothing + (Just Weekly) + Nothing + , SitemapUrl + "http://www.example.com/catalog?item=73&desc=vacation_new_zealand" + (Just $ UTCTime (fromGregorian 2004 12 23) 0) + (Just Weekly) + Nothing + , SitemapUrl + "http://www.example.com/catalog?item=74&desc=vacation_newfoundland" + (Just $ UTCTime (fromGregorian 2004 12 23) 64815) + Nothing + (Just 0.3) + , SitemapUrl + "http://www.example.com/catalog?item=83&desc=vacation_usa" + (Just $ UTCTime (fromGregorian 2004 11 23) 0) + Nothing + Nothing + ] + in multipleUrlSitemapFixture @=? renderSitemap (Sitemap urls) + +multipleUrlSitemapFixture :: BS.ByteString +multipleUrlSitemapFixture = + [r| +http://www.example.com/2005-01-01T00:00:00+00:00monthly0.8http://www.example.com/catalog?item=12&desc=vacation_hawaiiweeklyhttp://www.example.com/catalog?item=73&desc=vacation_new_zealand2004-12-23T00:00:00+00:00weeklyhttp://www.example.com/catalog?item=74&desc=vacation_newfoundland2004-12-23T18:00:15+00:000.3http://www.example.com/catalog?item=83&desc=vacation_usa2004-11-23T00:00:00+00:00|] + + +sitemapIndex :: Assertion +sitemapIndex = + let sitemaps = + [ IndexEntry + "http://www.example.com/sitemap1.xml.gz" + ( Just + $ UTCTime (fromGregorian 2004 10 01) + $ 18 + * 60 + * 60 + + 23 + * 60 + + 17 + ) + , IndexEntry "http://www.example.com/sitemap2.xml.gz" + (Just $ UTCTime (fromGregorian 2005 01 01) 0) + ] + in sitemapIndexFixture @=? renderSitemapIndex (SitemapIndex sitemaps) + + +sitemapIndexFixture :: BS.ByteString +sitemapIndexFixture = + [r| +http://www.example.com/sitemap1.xml.gz2004-10-01T18:23:17+00:00http://www.example.com/sitemap2.xml.gz2005-01-01T00:00:00+00:00|]