diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog for servant-seo + +## 0.1.1 -- 2020-07-12 + +- Fix frequency processing. +- Fix priority processing. + +## 0.1.0 -- 2020-07-11 + +- /robots.txt deriving from API: Disallow, Sitemap, User-agent commands. +- /sitemap.xml deriving from API: Frequency, Priority optional tags included. +- sitemap index support. diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,7 +0,0 @@ -# Changelog for servant-sitemap - -## 0.1.0 -- 2020-07-11 - -- /robots.txt deriving from API: Disallow, Sitemap, User-agent commands. -- /sitemap.xml deriving from API: Frequency, Priority optional tags included. -- sitemap index support. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,9 @@ # servant-seo +[![Build Status](https://travis-ci.org/swamp-agr/servant-seo.svg?branch=master)](https://travis-ci.org/swamp-agr/servant-seo) + +[![Hackage Status](https://matrix.hackage.haskell.org/api/v2/packages/servant-seo/badge)](https://matrix.hackage.haskell.org/api/v2/packages/servant-seo/badge) + ## Installation - Add `servant-seo` to project dependencies. diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Main where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import qualified Network.Wai.Handler.Warp as Warp +import Servant +import Servant.HTML.Blaze (HTML) +import Text.Blaze (ToMarkup) + +import Servant.Seo.Combinators +import Servant.Seo.Sitemap +import Servant.Seo.UI + +newtype NewsPage = NewsPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +newtype NewsUrl = NewsUrl Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) + +newtype SearchResultPage = SearchResultPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +newtype AboutPage = AboutPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +newtype HomePage = HomePage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +newtype SearchPattern = SearchPattern Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData) + +newtype SearchResultsPage = SearchResultsPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) + +newtype BlogUrl = BlogUrl Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) + +newtype BlogPage = BlogPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +newtype BlogComment = BlogComment Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, FromJSON) + +data Login = Login + { username :: !Text + , password :: !Text + } + deriving (Eq, Show, Generic, FromJSON) + +newtype AdminPage = AdminPage Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromHttpApiData, ToMarkup) + +-- *** User instances + +instance ToSitemapPathPiece BlogUrl where + getPathPiecesForIndexing _ _ = pure $ toUrl <$> ([0 .. 100000] :: [Int]) + where + toUrl = BlogUrl . Text.pack . show + +instance ToSitemapPathPiece NewsUrl where + getPathPiecesForIndexing _ _ = pure $ toUrl <$> ([0 .. 100] :: [Int]) + where + toUrl = NewsUrl . Text.pack . show + +instance ToSitemapParamPart SearchPattern where + getParamsForIndexing _ _ = pure $ SearchPattern . Text.pack <$> samples + where + samples = [ [ c1, c2 ] | c1 <- ['a' .. 'z'], c2 <- ['0' .. '9'] ] + +-- ** Example API + +type PublicAPI + = Get '[HTML] HomePage + :<|> ("blog" :> Frequency 'Always :> BlogAPI) + :<|> ("news" :> Capture ":newsurl" NewsUrl :> Get '[HTML] NewsPage) + :<|> ("search" :> QueryParam "q" SearchPattern :> Get '[HTML] SearchResultsPage) + :<|> ("about" :> Priority '(1,0) :> Get '[HTML] AboutPage) + :<|> "auth" :> ReqBody '[JSON] Login :> Post '[JSON] NoContent + +type BlogAPI + = Capture ":blogurl" BlogUrl :> Get '[HTML] BlogPage + :<|> Capture ":blogurl" BlogUrl + :> ReqBody '[JSON] BlogComment + :> Post '[JSON, HTML] BlogPage + +type ProtectedAPI = Disallow "admin" :> Get '[HTML] AdminPage + +type StaticAPI = "cdn" :> Disallow "static" :> Raw + +type API = StaticAPI :<|> ProtectedAPI :<|> PublicAPI + +-- ** Example app + +api :: Proxy API +api = Proxy + +server :: Server API +server + = serveStatic + :<|> serveProtected + :<|> servePublic + +serveProtected :: Handler AdminPage +serveProtected = throwError err401 + +servePublic :: Server PublicAPI +servePublic + = serveHome + :<|> (serveBlog :<|> servePostBlogComment) + :<|> serveNews + :<|> serveSearch + :<|> serveAbout + :<|> serveAuth + +serveHome :: Handler HomePage +serveHome = pure (HomePage "") + +serveBlog :: BlogUrl -> Handler BlogPage +serveBlog _ = pure (BlogPage "") + +servePostBlogComment :: BlogUrl -> BlogComment -> Handler BlogPage +servePostBlogComment _ _ = pure (BlogPage "") + +serveSearch :: Maybe SearchPattern -> Handler SearchResultsPage +serveSearch _ = pure (SearchResultsPage "") + +serveAbout :: Handler AboutPage +serveAbout = pure (AboutPage "") + +serveAuth :: Login -> Handler NoContent +serveAuth _ = pure NoContent + +serveNews :: NewsUrl -> Handler NewsPage +serveNews _ = pure (NewsPage "") + +serveStatic :: Server StaticAPI +serveStatic = serveDirectoryWebApp "." + +startServer :: IO () +startServer = do + Warp.runSettings Warp.defaultSettings + $ serveWithSeo website api server + where + website = "https://example.com" + +main :: IO () +main = startServer diff --git a/example/example.hs b/example/example.hs deleted file mode 100644 --- a/example/example.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Main where - -import Data.Aeson -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Generics (Generic) -import qualified Network.Wai.Handler.Warp as Warp -import Servant -import Servant.HTML.Blaze (HTML) -import Text.Blaze (ToMarkup) - -import Servant.Seo.Combinators -import Servant.Seo.Sitemap -import Servant.Seo.UI - -newtype NewsPage = NewsPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - -newtype NewsUrl = NewsUrl Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) - -newtype SearchResultPage = SearchResultPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - -newtype AboutPage = AboutPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - -newtype HomePage = HomePage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - -newtype SearchPattern = SearchPattern Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData) - -newtype SearchResultsPage = SearchResultsPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) - -newtype BlogUrl = BlogUrl Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, ToHttpApiData, FromHttpApiData, ToMarkup) - -newtype BlogPage = BlogPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - -newtype BlogComment = BlogComment Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, FromJSON) - -data Login = Login - { username :: !Text - , password :: !Text - } - deriving (Eq, Show, Generic, FromJSON) - -newtype AdminPage = AdminPage Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromHttpApiData, ToMarkup) - --- *** User instances - -instance ToSitemapPathPiece BlogUrl where - getPathPiecesForIndexing _ _ = pure $ toUrl <$> ([0 .. 100000] :: [Int]) - where - toUrl = BlogUrl . Text.pack . show - -instance ToSitemapPathPiece NewsUrl where - getPathPiecesForIndexing _ _ = pure $ toUrl <$> ([0 .. 100] :: [Int]) - where - toUrl = NewsUrl . Text.pack . show - -instance ToSitemapParamPart SearchPattern where - getParamsForIndexing _ _ = pure $ SearchPattern . Text.pack <$> samples - where - samples = [ [ c1, c2 ] | c1 <- ['a' .. 'z'], c2 <- ['0' .. '9'] ] - --- ** Example API - -type PublicAPI - = Get '[HTML] HomePage - :<|> ("blog" :> Frequency 'Always :> BlogAPI) - :<|> ("news" :> Capture ":newsurl" NewsUrl :> Get '[HTML] NewsPage) - :<|> ("search" :> QueryParam "q" SearchPattern :> Get '[HTML] SearchResultsPage) - :<|> ("about" :> Priority '(1,0) :> Get '[HTML] AboutPage) - :<|> "auth" :> ReqBody '[JSON] Login :> Post '[JSON] NoContent - -type BlogAPI - = Capture ":blogurl" BlogUrl :> Get '[HTML] BlogPage - :<|> Capture ":blogurl" BlogUrl - :> ReqBody '[JSON] BlogComment - :> Post '[JSON, HTML] BlogPage - -type ProtectedAPI = Disallow "admin" :> Get '[HTML] AdminPage - -type StaticAPI = "cdn" :> Disallow "static" :> Raw - -type API = StaticAPI :<|> ProtectedAPI :<|> PublicAPI - --- ** Example app - -api :: Proxy API -api = Proxy - -server :: Server API -server - = serveStatic - :<|> serveProtected - :<|> servePublic - -serveProtected :: Handler AdminPage -serveProtected = throwError err401 - -servePublic :: Server PublicAPI -servePublic - = serveHome - :<|> (serveBlog :<|> servePostBlogComment) - :<|> serveNews - :<|> serveSearch - :<|> serveAbout - :<|> serveAuth - -serveHome :: Handler HomePage -serveHome = pure (HomePage "") - -serveBlog :: BlogUrl -> Handler BlogPage -serveBlog _ = pure (BlogPage "") - -servePostBlogComment :: BlogUrl -> BlogComment -> Handler BlogPage -servePostBlogComment _ _ = pure (BlogPage "") - -serveSearch :: Maybe SearchPattern -> Handler SearchResultsPage -serveSearch _ = pure (SearchResultsPage "") - -serveAbout :: Handler AboutPage -serveAbout = pure (AboutPage "") - -serveAuth :: Login -> Handler NoContent -serveAuth _ = pure NoContent - -serveNews :: NewsUrl -> Handler NewsPage -serveNews _ = pure (NewsPage "") - -serveStatic :: Server StaticAPI -serveStatic = serveDirectoryWebApp "." - -startServer :: IO () -startServer = do - Warp.runSettings Warp.defaultSettings - $ serveWithSeo website api server - where - website = "https://example.com" - -main :: IO () -main = startServer diff --git a/servant-seo.cabal b/servant-seo.cabal --- a/servant-seo.cabal +++ b/servant-seo.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: servant-seo -version: 0.1.0 +version: 0.1.1 synopsis: Generate Robots.txt and Sitemap.xml specification for your servant API. description: Please see the README on GitHub at homepage: https://github.com/swamp-agr/servant-seo#readme @@ -13,10 +13,11 @@ license: BSD3 license-file: LICENSE build-type: Custom +Tested-with: GHC ==8.6.5 || ==8.8.3 extra-source-files: README.md - ChangeLog.md - example/example.hs + CHANGELOG.md + example/Example.hs example/example.cabal source-repository head @@ -51,7 +52,7 @@ , containers , http-media , lens >= 4.18.1 - , servant + , servant >= 0.16 , servant-blaze , servant-server , text diff --git a/src/Servant/Seo.hs b/src/Servant/Seo.hs --- a/src/Servant/Seo.hs +++ b/src/Servant/Seo.hs @@ -135,12 +135,10 @@ -- >>> type AuthAPI = "auth" :> ReqBody '[JSON] Login :> Post '[JSON] NoContent -- >>> type PublicAPI = HomeAPI :<|> AboutAPI :<|> AuthAPI -- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI --- --- Use 'toSitemapInfo' to get the intermediate sitemap representation of API. --- -- >>> toSitemapInfo (Proxy :: Proxy API) --- SitemapInfo {_sitemapInfoEntries = [SitemapEntry {_sitemapPathPieces = [], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "about"], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing}], _sitemapInfoPresent = Just ()} +-- SitemapInfo {_sitemapInfoEntries = [SitemapEntry {_sitemapPathPieces = [], _sitemapQueryParts = [], _sitemapFrequency = Just Monthly, _sitemapPriority = Just "1.0"},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "about"], _sitemapQueryParts = [], _sitemapFrequency = Just Yearly, _sitemapPriority = Just "0.1"}], _sitemapInfoPresent = Just ()} -- +-- Use 'toSitemapInfo' to get the intermediate sitemap representation of API. -- 'toSitemapInfo' will automatically skip all HTTP non-GET requests or other content types like @JSON@, @XML@, @PlainText@ and etc. -- -- Only @Get '[HTML] a@ will be accepted. @@ -149,7 +147,7 @@ -- -- >>> Right sitemapResponse <- runHandler $ serveSitemap serverUrl (Proxy :: Proxy API) -- >>> BSL8.putStrLn sitemapResponse --- https://example.comhttps://example.com/about +-- https://example.commonthly1.0https://example.com/aboutyearly0.1 -- -- Again, there is helper 'apiWithSitemap'. -- @@ -171,10 +169,10 @@ -- -- >>> instance ToSitemapPathPiece NewsUrl where getPathPiecesForIndexing _ _ = pure $ (NewsUrl . Text.pack . show) <$> [0 .. 10] -- >>> toSitemapInfo (Proxy :: Proxy PublicAPI) --- SitemapInfo {_sitemapInfoEntries = [SitemapEntry {_sitemapPathPieces = [], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "about"], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "news",CaptureValues ["0","1","2","3","4","5","6","7","8","9","10"]], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing}], _sitemapInfoPresent = Just ()} +-- SitemapInfo {_sitemapInfoEntries = [SitemapEntry {_sitemapPathPieces = [], _sitemapQueryParts = [], _sitemapFrequency = Just Monthly, _sitemapPriority = Just "1.0"},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "about"], _sitemapQueryParts = [], _sitemapFrequency = Just Yearly, _sitemapPriority = Just "0.1"},SitemapEntry {_sitemapPathPieces = [UrlPathPiece "news",CaptureValues ["0","1","2","3","4","5","6","7","8","9","10"]], _sitemapQueryParts = [], _sitemapFrequency = Nothing, _sitemapPriority = Nothing}], _sitemapInfoPresent = Just ()} -- >>> Right sitemapResponse <- runHandler $ serveSitemap serverUrl (Proxy :: Proxy PublicAPI) -- >>> BSL8.putStrLn sitemapResponse --- https://example.comhttps://example.com/abouthttps://example.com/news/0https://example.com/news/1https://example.com/news/2https://example.com/news/3https://example.com/news/4https://example.com/news/5https://example.com/news/6https://example.com/news/7https://example.com/news/8https://example.com/news/9https://example.com/news/10 +-- https://example.commonthly1.0https://example.com/aboutyearly0.1https://example.com/news/0https://example.com/news/1https://example.com/news/2https://example.com/news/3https://example.com/news/4https://example.com/news/5https://example.com/news/6https://example.com/news/7https://example.com/news/8https://example.com/news/9https://example.com/news/10 -- -- See 'ToSitemapPathPiece' for more details. -- diff --git a/src/Servant/Seo/Sitemap.hs b/src/Servant/Seo/Sitemap.hs --- a/src/Servant/Seo/Sitemap.hs +++ b/src/Servant/Seo/Sitemap.hs @@ -291,7 +291,7 @@ -- FIXME: compare with previous values, choose frequent one. toSitemapInfo _ = do sitemap <- toSitemapInfo (Proxy :: Proxy api) - pure $ sitemap & sitemapInfoEntries . each %~ (sitemapFrequency . _Just .~ period') + pure $ sitemap & sitemapInfoEntries . each %~ (sitemapFrequency .~ Just period') where period' = getPeriod (Proxy :: Proxy period) @@ -300,7 +300,7 @@ toSitemapInfo _ = do sitemap <- toSitemapInfo (Proxy :: Proxy api) -- FIXME: compare with previous values, choose greater one. - pure $ sitemap & sitemapInfoEntries . each %~ (sitemapPriority . _Just .~ priority') + pure $ sitemap & sitemapInfoEntries . each %~ (sitemapPriority .~ Just priority') where n' = natVal (Proxy :: Proxy n) & fromInteger @Float m' = natVal (Proxy :: Proxy m) & fromInteger @Float