diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrey Prokopenko (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 Andrey Prokopenko 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,41 @@ +# servant-seo + +## Installation + +- Add `servant-seo` to project dependencies. + +## Usage + +1. Restrict API with `Disallow` combinator to prevent robots making requests. + + ```haskell + type ProtectedAPI = Disallow "admin" :> Get '[HTML] AdminPage + + type StaticAPI = "cdn" :> Disallow "static" :> Raw + ``` + +2. Add `Priority` and `Frequency` (optional step). + + ```haskell + typw BlogAPI = "blog" :> Frequency 'Always :> Get '[HTML] BlogPage + ``` + +3. Extend your API with something like: + + ```haskell + Warp.runSettings Warp.defaultSettings $ serveWithSeo website api server + where + website = "https://example.com" + ``` + +You will have `/robots.txt` and `/sitemap.xml` automatically generated and ready to be served with your API. + +See `Servant.Seo` module for detailed description and `example/Example.hs` for show case. + +## Acknowledgements + +This library would not have happened without these people. Thank you! + + - @fizruk and **Servant Contributors**: as source of inspiration. + - @isovector: for `Thinking with types` book. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main = defaultMainWithDoctests "doctests" diff --git a/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -0,0 +1,28 @@ +name: example +version: 1.0 +synopsis: servant-seo demo +description: servant-seo demo +license: BSD3 +license-file: LICENSE +author: Andrey Prokopenko +maintainer: persiantiger@yandex.ru +copyright: (c) 2020 Andrey Prokopenko +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable servant-seo-example + ghc-options: -Wall + hs-source-dirs: . + main-is: Example.hs + build-depends: base + , servant + , servant-server + , servant-seo + , aeson + , text + , servant-blaze + , blaze-markup + , warp + default-language: Haskell2010 + 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/servant-seo.cabal b/servant-seo.cabal new file mode 100644 --- /dev/null +++ b/servant-seo.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +name: servant-seo +version: 0.1.0 +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 +bug-reports: https://github.com/swamp-agr/servant-seo/issues +author: Andrey Prokopenko +maintainer: persiantiger@yandex.ru +copyright: Andrey Prokopenko (c) 2020 +category: Web, Servant +license: BSD3 +license-file: LICENSE +build-type: Custom +extra-source-files: + README.md + ChangeLog.md + example/example.hs + example/example.cabal + +source-repository head + type: git + location: https://github.com/swamp-agr/servant-seo + +custom-setup + setup-depends: + base >=4.9 && <4.14, + Cabal >= 1.24 && <3.1, + cabal-doctest >=1.0.6 && <1.1 + +library + ghc-options: -Wall + exposed-modules: + Servant.Seo + , Servant.Seo.Combinators + , Servant.Seo.Robots + , Servant.Seo.Sitemap + , Servant.Seo.UI + + other-modules: + Paths_servant_seo + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , aeson + , binary + , blaze-markup + , bytestring + , containers + , http-media + , lens >= 4.18.1 + , servant + , servant-blaze + , servant-server + , text + , warp + , xml-conduit + default-language: Haskell2010 + +test-suite doctests + ghc-options: -Wall + build-depends: + base, + directory >= 1.0, + doctest >= 0.11.1 && <0.18, + servant-seo, + QuickCheck, + filepath + default-language: Haskell2010 + hs-source-dirs: test + main-is: doctests.hs + type: exitcode-stdio-1.0 diff --git a/src/Servant/Seo.hs b/src/Servant/Seo.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Seo.hs @@ -0,0 +1,221 @@ +-- | +-- Module: Servant.Seo +-- License: BSD3 +-- Maintainer: Andrey Prokopenko +-- Stability: experimental +-- +-- This library provides useful SEO extension to servant ecosystem if you are intended to serve dynamic HTML pages with servant. +-- Extension consists of two parts: +-- +-- 1. Auto-generating @robots.txt@ from API. +-- +-- 2. Auto-generating @sitemap.xml@ from API. +-- +-- This library provides only 'Disallow' and 'Sitemap' instructions from for all robots. +-- +-- was implemented almost completely except gzip archivation for sitemap indeces and custom namespaces. +module Servant.Seo + ( -- * How to use this library + -- $howto0 + + -- ** Robots example #1 + -- $howto1 + + -- ** Sitemap example #1 + -- $howto2 + + -- ** Sitemap example #2 + -- $howto3 + + -- ** Sitemap example #3 + -- $howto4 + + -- ** Sitemap example #4 + -- $howto5 + + -- ** Robots example #2 + -- $howto6 + + -- ** Re-exports + module Servant.Seo.Combinators + , module Servant.Seo.Robots + , module Servant.Seo.Sitemap + , module Servant.Seo.UI + ) where + +import Servant.Seo.Combinators +import Servant.Seo.Robots +import Servant.Seo.Sitemap +import Servant.Seo.UI + +-- $setup +-- >>> import Text.Blaze (ToMarkup) +-- >>> import Data.Text (Text) +-- >>> import Servant.API +-- >>> import Servant (Proxy (..)) +-- >>> import Servant.Server (runHandler) +-- >>> import Servant.HTML.Blaze (HTML) +-- >>> import Data.Aeson (FromJSON) +-- >>> import GHC.Generics (Generic) +-- >>> import qualified Data.Text as Text +-- >>> import qualified Data.Text.IO as Text +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 +-- >>> :set -XDerivingStrategies -XGeneralizedNewtypeDeriving -XDataKinds -XTypeOperators -XOverloadedStrings -XDeriveGeneric -XDeriveAnyClass +-- >>> newtype HomePage = HomePage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> newtype AdminPage = AdminPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> data Login = Login { username :: Text, password :: Text } deriving (Eq, Show, Generic, FromJSON) +-- >>> newtype AboutPage = AboutPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> newtype NewsPage = NewsPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> newtype NewsUrl = NewsUrl Text deriving newtype (ToMarkup, ToHttpApiData, FromHttpApiData) +-- >>> type NewsAPI = "news" :> Capture ":newsurl" NewsUrl :> Get '[HTML] NewsPage +-- >>> type StaticAPI = "cdn" :> Disallow "static" :> Raw +-- >>> type ProtectedAPI = Disallow "admin" :> Get '[HTML] AdminPage +-- >>> let serverUrl = ServerUrl "https://example.com" +-- >>> type HomeAPI = Priority '(1,0) :> Frequency 'Monthly :> Get '[HTML] HomePage +-- >>> type AboutAPI = Frequency 'Yearly :> Priority '(0,1) :> "about" :> Get '[HTML] AboutPage +-- >>> type AuthAPI = "auth" :> ReqBody '[JSON] Login :> Post '[JSON] NoContent +-- >>> type PublicAPI = Get '[HTML] HomePage +-- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI + +-- $howto0 +-- +-- This module describes how to extend servant API to get handlers for @/sitemap.xml@ and @/robots.txt@. + +-- $howto1 +-- +-- Consider initial API: +-- +-- >>> newtype HomePage = HomePage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> newtype AdminPage = AdminPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> type PublicAPI = Get '[HTML] HomePage +-- >>> type StaticAPI = "cdn" :> "static" :> Raw +-- >>> type ProtectedAPI = "admin" :> Get '[HTML] AdminPage +-- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI +-- +-- We want here to restrict robots on 'StaticAPI' and 'ProtectedAPI'. +-- +-- >>> type StaticAPI = "cdn" :> Disallow "static" :> Raw +-- >>> type ProtectedAPI = Disallow "admin" :> Get '[HTML] AdminPage +-- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI +-- +-- 'toRobots' function provides API analysis and produces 'RobotsInfo'. +-- +-- >>> toRobots (Proxy :: Proxy API) +-- RobotsInfo {_robotsSitemapPath = Nothing, _robotsDisallowedPaths = [DisallowedPathPiece "/cdn/static",DisallowedPathPiece "/admin"]} +-- +-- For 'RobotsInfo' you can use 'serveRobots' handler. @/robots.txt@ will be look like: +-- +-- >>> let serverUrl = ServerUrl "https://example.com" +-- >>> Right robotsResponse <- runHandler (serveRobots (ServerUrl "https://example.com") (toRobots (Proxy :: Proxy API))) +-- >>> robotsResponse +-- "User-agent: *\nDisallow /cdn/static\nDisallow /admin\n" +-- +-- +-- Moreover, API could be easily extended with 'apiWithRobots'. +-- +-- >>> :t apiWithRobots (Proxy :: Proxy API) +-- apiWithRobots (Proxy :: Proxy API) :: Proxy (RobotsAPI :<|> API) +-- +-- 'serveWithRobots' provides extension for both initial API and its implementation with 'RobotsAPI'. + +-- $howto2 +-- +-- Extend API from previous section with @POST \/auth@ route and @GET \/about@ page: +-- +-- >>> data Login = Login { username :: Text, password :: Text } deriving (Eq, Show, Generic, FromJSON) +-- >>> newtype AboutPage = AboutPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> type PublicAPI = Get '[HTML] HomePage :<|> "about" :> Get '[HTML] AboutPage :<|> "auth" :> ReqBody '[JSON] Login :> Post '[JSON] NoContent +-- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI +-- +-- Consider e.g., that Home page could be updated monthly and About page could be updated once per year. +-- Home page will have the highest priority. And about page will have the lowest one. +-- +-- >>> type HomeAPI = Priority '(1,0) :> Frequency 'Monthly :> Get '[HTML] HomePage +-- >>> type AboutAPI = Frequency 'Yearly :> Priority '(0,1) :> "about" :> Get '[HTML] AboutPage +-- >>> 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 ()} +-- +-- '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. +-- +-- For 'SitemapInfo' there is also 'serveSitemap' function. +-- +-- >>> Right sitemapResponse <- runHandler $ serveSitemap serverUrl (Proxy :: Proxy API) +-- >>> BSL8.putStrLn sitemapResponse +-- https://example.comhttps://example.com/about +-- +-- Again, there is helper 'apiWithSitemap'. +-- +-- >>> :t apiWithSitemap (Proxy :: Proxy API) +-- apiWithSitemap (Proxy :: Proxy API) :: Proxy (SitemapAPI :<|> API) +-- +-- 'serveWithSitemap' function will extend both API and corresponding handlers with 'SitemapAPI'. + +-- $howto3 +-- +-- Consider more complex example dependent on user supplied types and their ranges of possible values. +-- +-- >>> newtype NewsPage = NewsPage Text deriving newtype (ToMarkup, FromHttpApiData) +-- >>> newtype NewsUrl = NewsUrl Text deriving newtype (ToMarkup, ToHttpApiData, FromHttpApiData) +-- >>> type NewsAPI = "news" :> Capture ":newsurl" NewsUrl :> Get '[HTML] NewsPage +-- >>> type PublicAPI = HomeAPI :<|> AboutAPI :<|> AuthAPI :<|> NewsAPI +-- +-- In order to obtain sitemap for user supplied types in API (like 'Capture'), you have to provide instance to 'ToSitemapPathPiece' type class for corresponding captured type, i.e. the way to get the list of available values that could lead to real pages. Otherwise, empty list will be supplied and such API branch would be ignored. +-- +-- >>> 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 ()} +-- >>> 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 +-- +-- See 'ToSitemapPathPiece' for more details. +-- + +-- $howto4 +-- +-- Query parameters could be handled in the same way as captured path pieces of URL. +-- There is another type class for that: 'ToSitemapParamPart'. +-- +-- >>> newtype SearchPattern = SearchPattern Text deriving newtype (ToMarkup, FromHttpApiData, ToHttpApiData) +-- >>> newtype SearchResultsPage = SearchResultsPage Text deriving newtype (ToMarkup) +-- >>> type SearchAPI = "search" :> QueryParam "q" SearchPattern :> Get '[HTML] SearchResultsPage +-- >>> instance ToSitemapParamPart SearchPattern where getParamsForIndexing _ _ = pure $ (SearchPattern . Text.pack) <$> [ [ c1, c2 ] | c1 <- ['a' .. 'e'], c2 <- ['0' .. '3'] ] +-- >>> toSitemapInfo (Proxy :: Proxy SearchAPI) +-- SitemapInfo {_sitemapInfoEntries = [SitemapEntry {_sitemapPathPieces = [UrlPathPiece "search"], _sitemapQueryParts = [(ParamName "q",[ParamValue "a0",ParamValue "a1",ParamValue "a2",ParamValue "a3",ParamValue "b0",ParamValue "b1",ParamValue "b2",ParamValue "b3",ParamValue "c0",ParamValue "c1",ParamValue "c2",ParamValue "c3",ParamValue "d0",ParamValue "d1",ParamValue "d2",ParamValue "d3",ParamValue "e0",ParamValue "e1",ParamValue "e2",ParamValue "e3"])], _sitemapFrequency = Nothing, _sitemapPriority = Nothing}], _sitemapInfoPresent = Just ()} +-- >>> Right sitemapResponse <- runHandler $ serveSitemap serverUrl (Proxy :: Proxy SearchAPI) +-- >>> BSL8.putStrLn sitemapResponse +-- https://example.com/search?q=a0https://example.com/search?q=a1https://example.com/search?q=a2https://example.com/search?q=a3https://example.com/search?q=b0https://example.com/search?q=b1https://example.com/search?q=b2https://example.com/search?q=b3https://example.com/search?q=c0https://example.com/search?q=c1https://example.com/search?q=c2https://example.com/search?q=c3https://example.com/search?q=d0https://example.com/search?q=d1https://example.com/search?q=d2https://example.com/search?q=d3https://example.com/search?q=e0https://example.com/search?q=e1https://example.com/search?q=e2https://example.com/search?q=e3 +-- +-- See 'ToSitemapParamPart' for more details. +-- + +-- $howto5 +-- +-- Consider following API: +-- +-- >>> instance ToSitemapPathPiece NewsUrl where getPathPiecesForIndexing _ _ = pure $ (NewsUrl . Text.pack . show) <$> [0 .. 50001] +-- >>> type PublicAPI = HomeAPI :<|> AboutAPI :<|> AuthAPI :<|> NewsAPI +-- >>> Right sitemapResponse <- runHandler $ serveSitemap serverUrl (Proxy :: Proxy PublicAPI) +-- >>> BSL8.putStrLn sitemapResponse +-- https://example.com/0/sitemap.xmlhttps://example.com/1/sitemap.xmlhttps://example.com/2/sitemap.xmlhttps://example.com/3/sitemap.xml +-- +-- If sitemap page has more than 50000 URLs, it should be replaced with sitemap index page according to sitemap specification. +-- Each URL inside XML would be accesible. Look on 'SitemapAPI' definition for more details. + +-- $howto6 +-- +-- >>> type API = PublicAPI :<|> StaticAPI :<|> ProtectedAPI +-- >>> Right robotsResponse <- runHandler (serveRobots (ServerUrl "https://example.com") (toRobots $ apiWithSitemap (Proxy :: Proxy API))) +-- >>> robotsResponse +-- "User-agent: *\nDisallow /cdn/static\nDisallow /admin\n\nSitemap: https://example.com/sitemap.xml\n" +-- +-- API extended with sitemap will automatically be populated with link to sitemap xml page. +-- To serve both robots and sitemap in advance to your API look for 'serveWithSeo' helper function. diff --git a/src/Servant/Seo/Combinators.hs b/src/Servant/Seo/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Seo/Combinators.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Seo.Combinators where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, Nat, Symbol) +import qualified Network.HTTP.Media as M +import Servant + +-- ** XML + +-- | Content-Type representing @text\/xml@. Used for serving @\/sitemap.xml@. +data XML deriving Typeable + +-- | @text/xml@ +instance Accept XML where + contentType _ = "text" M.// "xml" + +-- | @BSL.fromStrict . Text.encodeUtf8@ +instance MimeRender XML Text where + mimeRender _ = BSL.fromStrict . Text.encodeUtf8 + +-- | @BSL.fromStrict@ +instance MimeRender XML ByteString where + mimeRender _ = BSL.fromStrict + +-- | @id@ +instance MimeRender XML BSL.ByteString where + mimeRender _ = id + +-- ** Disallow + +-- | Mark path as disallowed for indexing. +-- +-- Example: +-- +-- >>> -- GET /admin/crm +-- >>> type API = Disallow "admin" :> "crm" :> Get '[HTML] CrmPage +-- +-- Code above will be transformed into @Disallow /admin@. +-- +-- Note: 'Disallow' impacts @sitemap.xml@ excluding underlying URLs from resulted sitemap. +data Disallow (sym :: Symbol) + +-- | 'Disallow' does not change specification at all. +instance (KnownSymbol sym, HasServer api context) => HasServer (Disallow sym :> api) context where + type ServerT (Disallow sym :> api) m = ServerT (sym :> api) m + + route (Proxy :: Proxy (Disallow sym :> api)) context server = + route (Proxy @(sym :> api)) context server + + hoistServerWithContext _ pc nt api = + hoistServerWithContext (Proxy @(sym :> api)) pc nt api + +-- ** Frequency + +-- | 'Frequency' optional parameter for @sitemap.xml@. Shows to bots how often page will be changed. +-- Used with @Period@. +-- +-- >>> type API = Frequency 'Yearly :> "about.php" :> Get '[HTML] AboutPage +-- +-- Code above will be transformed in corresponding XML: @\\https:\/\/example.com\/about.php\<\/loc\>\yearly\<\/freq\>\<\/url\>@. +data Frequency (period :: Period) + +-- | @Frequency@ does not change specification at all. +instance (HasPeriod period, HasServer api context) => + HasServer (Frequency period :> api) context where + type ServerT (Frequency period :> api) m = ServerT api m + + route (Proxy :: Proxy (Frequency period :> api)) context server = + route (Proxy @api) context server + + hoistServerWithContext _ pc nt api = + hoistServerWithContext (Proxy @api) pc nt api + +-- ** Period + +-- | 'Period' is a type parameter for 'Frequency'. +data Period = Never + | Yearly + | Monthly + | Weekly + | Daily + | Hourly + | Always + deriving (Show, Eq, Ord, Enum, Generic) + +class HasPeriod a where + getPeriod :: Proxy a -> Period + +instance HasPeriod 'Never where getPeriod _ = Never + +instance HasPeriod 'Yearly where getPeriod _ = Yearly + +instance HasPeriod 'Monthly where getPeriod _ = Monthly + +instance HasPeriod 'Weekly where getPeriod _ = Weekly + +instance HasPeriod 'Daily where getPeriod _ = Daily + +instance HasPeriod 'Hourly where getPeriod _ = Hourly + +instance HasPeriod 'Always where getPeriod _ = Always + + +-- ** Priority + +-- | 'Priority' optional parameter for @sitemap.xml@. Set priority on listed page to bots. +-- Possible values are between @'(0,0)@ and @'(1,0)@. +-- +-- >>> type API = Priority '(1,0) :> "news.php" :> Get '[HTML] NewsPage +-- +-- Code above will be transformed in corresponding XML: @\\https:\/\/example.com\/news.php\<\/loc\>\1.0\<\/priority\>\<\/url\>@. +data Priority (priority :: (Nat, Nat)) + +instance (HasServer api context) => + HasServer (Priority priority :> api) context where + type ServerT (Priority priority :> api) m = ServerT api m + + route (Proxy :: Proxy (Priority priority :> api)) context server = + route (Proxy @api) context server + + hoistServerWithContext _ pc nt api = + hoistServerWithContext (Proxy @api) pc nt api + +-- $setup +-- >>> :set -XDerivingStrategies -XGeneralizedNewtypeDeriving +-- >>> import Servant.HTML.Blaze (HTML) +-- >>> import Text.Blaze (ToMarkup) +-- >>> newtype CrmPage = CrmPage Text deriving newtype (ToMarkup) +-- >>> newtype AboutPage = AboutPage Text deriving newtype (ToMarkup) +-- >>> newtype NewsPage = NewsPage Text deriving newtype (ToMarkup) + diff --git a/src/Servant/Seo/Robots.hs b/src/Servant/Seo/Robots.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Seo/Robots.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Seo.Robots where + +import Control.Lens +import Data.Coerce (coerce) +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, KnownSymbol, Nat, symbolVal) +import Servant +import Text.Blaze (ToMarkup) + +import Servant.Seo.Combinators + +-- * Robots.txt + +-- ** RobotsInfo + +-- | Intermediate structure representing @robots.txt@ file. +-- All API parts marked as 'Disallow' would be aggregated into 'RobotsInfo' during compilation and translated to @robots.txt@ content. +data RobotsInfo = RobotsInfo + { _robotsSitemapPath :: Maybe () -- ^ Indicate whether sitemap should be present in robots file or not. + , _robotsDisallowedPaths :: [DisallowedPathPiece] -- ^ Path pieces that should be present in robots file. + } + deriving (Show, Eq, Generic) + +-- | Part of URL that should be present in robots file. +newtype DisallowedPathPiece = DisallowedPathPiece Text + deriving stock (Show, Eq, Generic) + deriving newtype (Ord, ToMarkup) + +makeLenses ''RobotsInfo + +-- | Empty unit of 'RobotsInfo'. +instance Monoid RobotsInfo where + mempty = RobotsInfo Nothing [] + +instance Semigroup RobotsInfo where + RobotsInfo s1 d1 <> RobotsInfo s2 d2 = RobotsInfo (s1 <> s2) (d1 <> d2) + +-- ** HasRobots + +-- | Servant API extension. +-- It describes how to build 'RobotsInfo' from servant API. +-- Most of types add nothing to it. +class HasRobots a where + toRobots :: Proxy a -> RobotsInfo + +instance HasRobots Raw where + toRobots _ = mempty + +instance HasRobots EmptyAPI where + toRobots _ = mempty + +-- | Collect different path pieces. +instance (HasRobots a, HasRobots b) => HasRobots (a :<|> b) where + toRobots _ = toRobots (Proxy :: Proxy a) <> toRobots (Proxy :: Proxy b) + +instance HasRobots sub => HasRobots (WithNamedContext x c sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (HttpVersion :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (StreamBody' mods fr ct a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (ReqBody' mods cs a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (RemoteHost :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (QueryParam' mods sym a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (QueryParams sym a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (QueryFlag sym :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (Header' mods sym a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (IsSecure :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots api => HasRobots (Summary desc :> api) where + toRobots _ = toRobots (Proxy :: Proxy api) + +instance HasRobots api => HasRobots (Description desc :> api) where + toRobots _ = toRobots (Proxy :: Proxy api) + +instance (KnownSymbol sym, HasRobots sub) => + HasRobots (Capture' mods sym a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (CaptureAll sym a :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +instance HasRobots sub => HasRobots (Vault :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) + +-- | Append path piece to existing 'DisallowedPathPiece'. +instance (HasRobots sub, KnownSymbol sym) => HasRobots (sym :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) & decide piece + where + piece = (Text.append "/" . Text.pack . symbolVal) (Proxy :: Proxy sym) + decide x ys@RobotsInfo{..} = case _robotsDisallowedPaths of + [] | piece /= "/sitemap.xml" -> ys + | otherwise -> ys & robotsSitemapPath ?~ () + _ -> ys & robotsDisallowedPaths .~ (DisallowedPathPiece . Text.append x . coerce <$> (ys ^. robotsDisallowedPaths)) + +-- | Generate new 'DisallowedPathPiece' from path piece marked as 'Disallow'. +instance (HasRobots sub, KnownSymbol sym) => HasRobots (Disallow sym :> sub) where + toRobots _ = toRobots (Proxy :: Proxy sub) & addPath piece + where + piece = (DisallowedPathPiece . Text.append "/" . Text.pack . symbolVal) (Proxy :: Proxy sym) + addPath x xs = RobotsInfo Nothing [x] <> xs + +instance {-# OVERLAPPABLE #-} (KnownNat status) => HasRobots (Verb method status cs NoContent) where + toRobots _ = mempty + +instance {-# OVERLAPPABLE #-} (KnownNat status) => + HasRobots (Verb method status cs a) where + toRobots _ = mempty + +instance {-# OVERLAPPABLE #-} (KnownNat status) => HasRobots (Verb (method :: Type) (status :: Nat) (cs :: [Type]) (Headers hs NoContent)) where + toRobots _ = mempty + +instance {-# OVERLAPPABLE #-} ( KnownNat status) => HasRobots (Verb (method :: Type) (status :: Nat) (cs :: [Type]) (Headers hs a)) where + toRobots _ = mempty + +-- | 'Frequency' as part of @sitemap.xml@ spec has no impact on @robots.txt@. +instance (HasPeriod period, HasRobots api) => HasRobots (Frequency period :> api) where + toRobots _ = toRobots (Proxy :: Proxy api) + +-- | 'Priority' as part of @sitemap.xml@ spec has no impact on @robots.txt@. +instance (HasRobots api) => + HasRobots (Priority priority :> api) where + toRobots _ = toRobots (Proxy :: Proxy api) diff --git a/src/Servant/Seo/Sitemap.hs b/src/Servant/Seo/Sitemap.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Seo/Sitemap.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Seo.Sitemap where + +import Control.Lens +import Control.Monad.IO.Class (MonadIO) +import qualified Data.Binary.Builder as Builder +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) +import qualified Data.Foldable as F +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, + symbolVal) +import Numeric (showFFloat) +import Servant +import Servant.HTML.Blaze (HTML) +import Text.Blaze (ToMarkup) +import Text.XML + +import Servant.Seo.Combinators + +-- * Sitemap + +-- ** SitemapInfo + +-- | Intermediate structure representing @sitemap.xml@ file. +-- During compilation API analysis performed. +-- All 'HTML' pages with 'Get' verb would be populated into 'SitemapInfo' and then updated to list of URLs, unless 'Disallow' happened in the path to page. +-- It consists of list of API branches and internal flag. +data SitemapInfo = SitemapInfo + { _sitemapInfoEntries :: [SitemapEntry] + , _sitemapInfoPresent :: Maybe () + } + deriving (Show, Eq, Generic, Ord) + +instance Monoid SitemapInfo where + mempty = SitemapInfo [] Nothing + +instance Semigroup SitemapInfo where + SitemapInfo e1 p1 <> SitemapInfo e2 p2 + = SitemapInfo (e1 <> e2) (p1 <> p2) + +-- | Represents single API branch. +-- Could contain multiple values based on user decision. +-- See 'ToSitemapParamPart' or 'ToSitemapPathPiece' for more details. +-- Also contain optional 'Frequency' and 'Priority'. +data SitemapEntry = SitemapEntry + { _sitemapPathPieces :: [PathPiece] + , _sitemapQueryParts :: [(ParamName, [ParamValue])] + , _sitemapFrequency :: Maybe Period + , _sitemapPriority :: Maybe Text + } + deriving (Show, Eq, Generic, Ord) + +instance Monoid SitemapEntry where + mempty = SitemapEntry [] [] Nothing Nothing + +instance Semigroup SitemapEntry where + SitemapEntry p1 q1 f1 r1 <> SitemapEntry p2 q2 f2 r2 = + SitemapEntry (p1 <> p2) (q1 <> q2) (maximum [f1, f2]) (maximum [r1, r2]) + +newtype ParamName = ParamName Text + deriving stock (Show, Eq, Generic) + deriving newtype (Ord, ToMarkup, ToHttpApiData) + +newtype ParamValue = ParamValue Text + deriving stock (Show, Eq, Generic) + deriving newtype (Ord, ToMarkup, ToHttpApiData) + +-- | Could be either path piece obtained from @path :: Symbol@ or list of possible captured values provided by user. +data PathPiece = UrlPathPiece Text + | CaptureValues [Text] + deriving (Show, Eq, Generic, Ord) + +-- | Checks that path piece is contained. +isEmpty :: PathPiece -> Bool +isEmpty (UrlPathPiece "") = True +isEmpty (CaptureValues []) = True +isEmpty _ = False + +-- ** User dependent decisions for sitemap. + +-- | How to get all possible values that should (or should not) be the parts of sitemap from query parameter values. +-- +-- Example (in combination with @Get '[HTML]@ will produce sitemap URLs): +-- +-- >>> newtype ArticleId = ArticleId Int deriving newtype (Show, Eq, Enum, Ord, Num, ToHttpApiData) +-- >>> instance ToSitemapParamPart ArticleId where getParamsForIndexing _ _ = pure [0..100500] +-- +-- Another example (params that have no affect on sitemap): +-- +-- >>> newtype SortBy = SortBy Text deriving newtype (Show, Eq, ToHttpApiData) +-- >>> instance ToSitemapParamPart SortBy where getParamsForIndexing _ _ = pure mempty +-- +class ToHttpApiData a => ToSitemapParamPart a where + -- ^ Should be provided by user. + getParamsForIndexing :: MonadIO m => Proxy a -> app -> m [a] + getParamsForIndexing _ _ = pure mempty + + -- ^ Default implementation of conversion to '[ParamValue]'. + toParamPart :: MonadIO m => Proxy a -> env -> m [ParamValue] + toParamPart proxy env = do + values <- getParamsForIndexing proxy env + pure $ ParamValue . toUrlPiece <$> values + +-- | How to get all possible captured values that should (or should not) be the parts of sitemap. +-- +-- Example (in combination with @Get '[HTML]@ will produce sitemap URLs): +-- +-- >>> newtype UserId = UserId Int deriving newtype (Show, Eq, Enum, Ord, Num, ToHttpApiData) +-- >>> instance ToSitemapPathPiece UserId where getPathPiecesForIndexing _ _ = pure [1..200000] +-- +-- Another example (captured values that have no affect on sitemap): +-- +-- >>> newtype Username = Username Text deriving newtype (Show, Eq, ToHttpApiData) +-- >>> instance ToSitemapPathPiece Username where getPathPiecesForIndexing _ _ = pure mempty +-- +class ToHttpApiData a => ToSitemapPathPiece a where + -- ^ Should be provided by user. + getPathPiecesForIndexing :: MonadIO m => Proxy a -> app -> m [a] + getPathPiecesForIndexing _ _ = pure mempty + + -- ^ Default implementation of conversion to 'PathPiece'. + toPathPiece :: MonadIO m => Proxy a -> env -> m PathPiece + toPathPiece proxy env = do + values <- getPathPiecesForIndexing proxy env + pure $ CaptureValues (toUrlPiece <$> values) + +makeLenses ''SitemapInfo +makeLenses ''SitemapEntry + +-- ** Transforming API to @SitemapInfo@ + +-- | Servant API extension. +-- It describes how to build 'SitemapInfo' representation from servant API. +-- There are plenty of types that add nothing to it. +-- +-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated +-- instance will loop indefinitely. +class HasSitemap a where + toSitemapInfo :: MonadIO m => Proxy a -> m SitemapInfo + toSitemapInfo proxy = toSitemapInfoWith () proxy + + toSitemapInfoWith :: MonadIO m => env -> Proxy a -> m SitemapInfo + toSitemapInfoWith _ = toSitemapInfo + + {-# MINIMAL toSitemapInfo | toSitemapInfoWith #-} + +instance HasSitemap Raw where + toSitemapInfo _ = pure mempty + +instance HasSitemap EmptyAPI where + toSitemapInfo _ = pure mempty + +-- | Collect multiple API branches together. +instance (HasSitemap a, HasSitemap b) => HasSitemap (a :<|> b) where + toSitemapInfo _ = do + sitemapA <- toSitemapInfo (Proxy :: Proxy a) + sitemapB <- toSitemapInfo (Proxy :: Proxy b) + pure (sitemapA <> sitemapB) + +instance HasSitemap sub => HasSitemap (WithNamedContext x c sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (HttpVersion :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (StreamBody' mods fr ct a :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (ReqBody' mods cs a :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (RemoteHost :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +-- | Extract all possible values under 'QueryParam'' and append them if sitemap is present for this particular branch. +instance (ToSitemapParamPart a, HasSitemap sub, KnownSymbol sym) => + HasSitemap (QueryParam' mods sym a :> sub) where + toSitemapInfoWith env _ = do + sitemap <- toSitemapInfo (Proxy :: Proxy sub) + vals <- toParamPart (Proxy :: Proxy a) env + let newSitemap + | sitemap == mempty = mempty + | null vals = sitemap + | otherwise + = sitemap & sitemapInfoEntries .~ newEntries sitemap vals + pure newSitemap + where + param = (ParamName . Text.pack . symbolVal) (Proxy :: Proxy sym) + + addQueryParts paramName paramValues x = x & sitemapQueryParts .~ new + where + new = x ^. sitemapQueryParts . to ((paramName, paramValues) :) + newEntries x vals = if x ^. sitemapInfoEntries . to null + then [addQueryParts param vals mempty] + else x ^. sitemapInfoEntries . to (fmap (addQueryParts param vals)) + +instance HasSitemap sub => HasSitemap (QueryFlag sym :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (Header' mods sym a :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (IsSecure :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap api => HasSitemap (Summary desc :> api) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy api) + +instance HasSitemap api => HasSitemap (Description desc :> api) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy api) + +-- | Extract all possible values under 'Capture'' and append them if sitemap is present for this particular branch. +instance (HasSitemap sub, ToSitemapPathPiece a) => + HasSitemap (Capture' mods sym a :> sub) where + toSitemapInfoWith env _ = do + sitemap <- toSitemapInfo (Proxy :: Proxy sub) + value <- toPathPiece (Proxy @a) env + pure $ if sitemap == mempty + then mempty + else + if isEmpty value + then sitemap + else sitemap & sitemapInfoEntries .~ newEntries sitemap value + + where + addPathPieces capturedValue x = x & sitemapPathPieces .~ new + where + new = x ^. sitemapPathPieces . to (capturedValue :) + + newEntries x capturedValue = if x ^. sitemapInfoEntries . to null + then [addPathPieces capturedValue mempty] + else x ^. sitemapInfoEntries . to (fmap (addPathPieces capturedValue)) + +instance HasSitemap sub => HasSitemap (CaptureAll sym a :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance HasSitemap sub => HasSitemap (Vault :> sub) where + toSitemapInfo _ = toSitemapInfo (Proxy :: Proxy sub) + +instance (HasSitemap sub, KnownSymbol sym) => HasSitemap (sym :> sub) where + toSitemapInfo _ = do + sitemap <- toSitemapInfo (Proxy :: Proxy sub) + pure $ if sitemap == mempty + then mempty + else sitemap & sitemapInfoEntries .~ newEntries sitemap + where + newEntries x = if x ^. sitemapInfoEntries . to null + then [addPathPiece piece mempty] + else x ^. sitemapInfoEntries . to (fmap (addPathPiece piece)) + piece = (UrlPathPiece . Text.pack . symbolVal) (Proxy :: Proxy sym) + addPathPiece p x = x & sitemapPathPieces .~ new + where + new = x ^. sitemapPathPieces . to (p :) + +-- | 'Disallow' combinator invalidates sitemap for particular API branch. +instance (HasSitemap sub, KnownSymbol sym) => HasSitemap (Disallow sym :> sub) where + toSitemapInfo _ = pure mempty + +instance {-# OVERLAPPABLE #-} (KnownNat status) => + HasSitemap (Verb method status cs a) where + toSitemapInfo _ = pure mempty + +-- | @Get '[HTML]@ enables sitemap for particular API branch. +instance {-# OVERLAPPING #-} (ToMarkup a) => HasSitemap (Get '[HTML] a) where + toSitemapInfo _ = pure (SitemapInfo [mempty] (Just ())) + +-- | Extracts 'Frequency' from API branch. +instance (HasPeriod period, HasSitemap api) => HasSitemap (Frequency period :> api) where + -- FIXME: compare with previous values, choose frequent one. + toSitemapInfo _ = do + sitemap <- toSitemapInfo (Proxy :: Proxy api) + pure $ sitemap & sitemapInfoEntries . each %~ (sitemapFrequency . _Just .~ period') + where + period' = getPeriod (Proxy :: Proxy period) + +-- | Extracts 'Priority' from API branch. +instance (KnownNat n, KnownNat m, HasSitemap api) => HasSitemap (Priority '(n, m) :> api) where + toSitemapInfo _ = do + sitemap <- toSitemapInfo (Proxy :: Proxy api) + -- FIXME: compare with previous values, choose greater one. + pure $ sitemap & sitemapInfoEntries . each %~ (sitemapPriority . _Just .~ priority') + where + n' = natVal (Proxy :: Proxy n) & fromInteger @Float + m' = natVal (Proxy :: Proxy m) & fromInteger @Float + priority' = (n' * 10 + m') / 10 + & min 1.0 & showFloat & Text.pack + + showFloat x = showFFloat (Just 1) x "" + +-- ** Rendering + +-- | Populated during 'SitemapInfo' processing. +-- 'SitemapUrl' would be rendered in XML node in runtime. +-- +-- Example: @\\https:\/\/example.com\/some\/url\<\/loc\>@. +data SitemapUrl = SitemapUrl + { _sitemapUrlLoc :: [SitemapLoc] + , _sitemapUrlFrequency :: Maybe Period + , _sitemapUrlPriority :: Maybe Text + } + deriving (Show, Eq, Generic, Ord) + +-- | Represents single URL listed in @sitemap.xml@. +newtype SitemapLoc = SitemapLoc Text + deriving stock (Show, Eq, Generic) + deriving newtype (Ord, ToMarkup) + +-- | Server prefix without trailing slash. +newtype ServerUrl = ServerUrl Text + deriving stock (Show, Eq, Generic) + deriving newtype (Ord, ToMarkup, IsString) + +-- | If sitemap consists of more than 50000 URLs, it should be indexed. +type SitemapIndex = (Int, [SitemapUrl]) + +newtype SitemapIx = SitemapIx Int + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromHttpApiData, ToHttpApiData) + +instance ToSitemapPathPiece SitemapIx + +makeLenses ''SitemapUrl + +-- | Transform single sitemap entry to list of URLs. +sitemapEntryToUrlList :: ServerUrl -> SitemapEntry -> SitemapUrl +sitemapEntryToUrlList server SitemapEntry {..} = SitemapUrl + { _sitemapUrlLoc = locs + , _sitemapUrlFrequency = _sitemapFrequency + , _sitemapUrlPriority = _sitemapPriority + } + where + locs = case (null paths, null queries) of + (False, False) -> [ SitemapLoc (coerce server <> path <> query) | path <- paths, query <- queries ] + (True, False) -> [ SitemapLoc (coerce server <> "/" <> query) | query <- queries ] + (False, True) -> [ SitemapLoc (coerce server <> path) | path <- paths ] + _ -> [ SitemapLoc (coerce server) ] + paths = _sitemapPathPieces + & F.foldr combinePaths [] + & fmap (escapeXmlEntities . toText) + where + combinePaths :: PathPiece -> [Builder] -> [Builder] + combinePaths p [] = case p of + UrlPathPiece piece -> [prepare piece] + CaptureValues pieces -> prepare <$> pieces + combinePaths p xs = case p of + UrlPathPiece piece -> prepend piece <$> xs + CaptureValues pieces -> concatMap (\piece -> prepend piece <$> xs) pieces + + prepare = Builder.append (Builder.fromByteString "/") . toEncodedUrlPiece + + prepend x = Builder.append (prepare x) + + queries = _sitemapQueryParts + & F.foldl' combineParams [] + & fmap (escapeXmlEntities . fixQuery . toText) + where + combineParams :: [Builder] -> (ParamName, [ParamValue]) -> [Builder] + combineParams [] (param, values) = values + & fmap toEncodedUrlPiece + & fmap (combine param) + combineParams xs paramWithValues = combineParams [] paramWithValues + & concatMap (\piece -> Builder.append piece <$> xs) + + combine p v = Builder.fromByteString "&" + <> toEncodedUrlPiece p + <> Builder.fromByteString "=" + <> v + + fixQuery q = if Text.null q then q else Text.cons '?' (Text.tail q) + + toText :: Builder -> Text + toText = Text.decodeUtf8 . BSL.toStrict . Builder.toLazyByteString + + escapeXmlEntities txt = txt + & Text.replace "&" "&" + & Text.replace "'" "'" + & Text.replace "\"" """ + & Text.replace ">" ">" + & Text.replace "<" "<" + +-- | Transform list of URLs to list of XML nodes. +sitemapUrlToNodes :: SitemapUrl -> [Node] +sitemapUrlToNodes SitemapUrl{..} = mkUrlNode "url" extra <$> _sitemapUrlLoc + where + extra = [ frequencyNode, priorityNode ] & catMaybes + frequencyNode = fromFrequency <$> _sitemapUrlFrequency + priorityNode = fromPriority <$> _sitemapUrlPriority + + fromFrequency = mkNodeWithContent "changefreq" . Text.toLower . Text.pack . show + fromPriority = mkNodeWithContent "priority" . coerce + +-- | Several XML rendering helpers. +mkNode :: Name -> [Node] -> Node +mkNode name childNodes = NodeElement (Element name Map.empty childNodes) + +mkNodeWithContent :: Name -> Text -> Node +mkNodeWithContent name content = mkNode name [NodeContent content] + +mkUrlNode :: Name -> [Node] -> SitemapLoc -> Node +mkUrlNode name extra loc = mkNode name (locNode : extra) + where + locNode = mkNodeWithContent "loc" (coerce loc) + +-- | Transform list of URLs to sitemap index XML nodes. +sitemapIndexUrlToNodes :: SitemapUrl -> [Node] +sitemapIndexUrlToNodes SitemapUrl{..} = mkUrlNode "sitemap" [] <$> _sitemapUrlLoc + +-- | Transform bunch of list of URLs to XML document. +sitemapUrlsToDocument :: ServerUrl -> [SitemapUrl] -> Document +sitemapUrlsToDocument server urlparts = Document + { documentPrologue = Prologue [] Nothing [] + , documentRoot = Element "urlset" (Map.fromList [namespace]) childNodes + , documentEpilogue = [] + } + where + namespace = ("xmlns", "http://www.sitemaps.org/schemas/sitemap/0.9") + childNodes = concatMap sitemapUrlToNodes urlparts + +-- | Transform list of sitemap index URLs to XML document. +sitemapIndexToDocument :: ServerUrl -> [SitemapUrl] -> Document +sitemapIndexToDocument server urlparts = Document + { documentPrologue = Prologue [] Nothing [] + , documentRoot = Element "sitemapindex" (Map.fromList [namespace]) childNodes + , documentEpilogue = [] + } + where + namespace = ("xmlns", "http://www.sitemaps.org/schemas/sitemap/0.9") + childNodes = concatMap sitemapIndexUrlToNodes urlparts + +sitemapUrlsToRootLBS :: ServerUrl -> [SitemapUrl] -> BSL.ByteString +sitemapUrlsToRootLBS serverUrl urls = if urls & concatMap _sitemapUrlLoc & length & (<= 50000) + then render sitemapUrlsToDocument urls + else render sitemapIndexToDocument indeces + where + render x ys = renderSitemapWith x serverUrl ys + indeces = urls & concatMap countLocGroups & length & pred & mkIndexList & fmap mkIndexUrl + countLocGroups :: SitemapUrl -> [Int] + countLocGroups x = x + & _sitemapUrlLoc + & length + & (realToFrac @_ @Double) + & (/ 50000) + & truncate + & mkIndexList + mkIndexList x = [0 .. x] + mkIndexUrl x = SitemapUrl + { _sitemapUrlLoc = pure $ SitemapLoc + $ coerce serverUrl <> "/" <> Text.pack (show x) <> "/sitemap.xml" + , _sitemapUrlFrequency = Nothing + , _sitemapUrlPriority = Nothing + } + +sitemapUrlsToSitemapMap :: ServerUrl -> [SitemapUrl] -> Map Int BSL.ByteString +sitemapUrlsToSitemapMap serverUrl urls = urls + & concatMap (splitUrlTo50KLocs []) + & zip [0..] + & Map.fromList + where + splitUrlTo50KLocs xs s = if s ^. sitemapUrlLoc . to length . to (<= 50000) + then mkLBS [s] : xs + else splitUrlTo50KLocs (currentLocsSitemap : xs) restLocsSitemap + where + currentLocsSitemap = mkLBS [s & sitemapUrlLoc %~ take 50000] + restLocsSitemap = s & sitemapUrlLoc %~ drop 50000 + mkLBS = renderSitemapWith sitemapUrlsToDocument serverUrl + +renderSitemapWith + :: (ServerUrl -> [SitemapUrl] -> Document) -> ServerUrl -> [SitemapUrl] -> BSL.ByteString +renderSitemapWith renderer serverUrl urls = renderer serverUrl urls & renderLBS def + +-- $setup +-- >>> :set -XDerivingStrategies -XGeneralizedNewtypeDeriving +-- >>> diff --git a/src/Servant/Seo/UI.hs b/src/Servant/Seo/UI.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Seo/UI.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Seo.UI where + +import Control.Lens +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Servant +import Servant.Seo.Combinators +import Servant.Seo.Robots +import Servant.Seo.Sitemap + +-- * robots.txt + +-- | Robots API. +-- Provides @\/robots.txt@. +type RobotsAPI = "robots.txt" :> Get '[PlainText] Text + +-- | Extends API with 'RobotsAPI'. +apiWithRobots + :: forall (api :: *). (HasServer api '[], HasRobots api) + => Proxy api + -> Proxy ( RobotsAPI :<|> api ) +apiWithRobots _ = Proxy + +-- | Provides "wrapper" around API. +-- Both API and corresponding 'Server' wrapped with 'RobotsAPI' and 'serveRobots' handler. +serveWithRobots + :: forall (api :: *). (HasServer api '[], HasRobots api) + => ServerUrl + -> Proxy api + -> Server api + -> Application +serveWithRobots serverUrl proxy appServer = serve extendedProxy extendedServer + where + extendedProxy :: Proxy (RobotsAPI :<|> api) + extendedProxy = apiWithRobots proxy + + extendedServer :: Server (RobotsAPI :<|> api) + extendedServer = serveRobots serverUrl (toRobots proxy) :<|> appServer + +-- | Handler for 'RobotsAPI'. +serveRobots :: ServerUrl -> RobotsInfo -> Handler Text +serveRobots serverUrl robots = robots + ^. robotsDisallowedPaths + . to (fmap (Text.append "Disallow " . coerce)) + . to addUserAgent + . to (addSitemap serverUrl) + . to Text.unlines + . to pure + where + addSitemap (ServerUrl url) r = if robots ^. robotsSitemapPath . to (== Nothing) + then r + else r <> ["", "Sitemap: " <> url <> "/sitemap.xml"] + + addUserAgent r = ["User-agent: *"] <> r + +-- * sitemap.xml + +-- | Sitemap API. +-- Provides both single @\/sitemap.xml@ and @\/sitemap\/:sitemap\/sitemap.xml@ in case of indexing. +-- If sitemap consists of more than 50000 URLs @\/sitemap.xml@ would return list of indeces to nested sitemaps. +type SitemapAPI + = "sitemap.xml" :> Get '[XML] BSL.ByteString + :<|> "sitemap" :> Capture ":sitemap" SitemapIx :> "sitemap.xml" :> Get '[XML] BSL.ByteString + +-- | Extends API with 'SitemapAPI'. +apiWithSitemap + :: forall (api :: *). (HasServer api '[], HasSitemap api) + => Proxy api + -> Proxy ( SitemapAPI :<|> api ) +apiWithSitemap _ = Proxy + +-- | Provides "wrapper" around API. +-- Both API and corresponding 'Server' wrapped with 'SitemapAPI' and 'serveSitemap' handler. +serveWithSitemap + :: forall (api :: *). (HasServer api '[], HasSitemap api) + => ServerUrl + -> Proxy api + -> Server api + -> Application +serveWithSitemap serverUrl proxy appServer = serve extendedProxy extendedServer + where + extendedProxy :: Proxy (SitemapAPI :<|> api) + extendedProxy = apiWithSitemap proxy + + extendedServer :: Server (SitemapAPI :<|> api) + extendedServer = sitemapServer serverUrl proxy :<|> appServer + +-- | 'Server' implementation for @sitemap.xml@ and indexed sitemaps (if present). +sitemapServer + :: forall (api :: *). (HasServer api '[], HasSitemap api) + => ServerUrl + -> Proxy api + -> Server SitemapAPI +sitemapServer serverUrl proxy = serveSitemap serverUrl proxy + :<|> serveNestedSitemap serverUrl proxy + +-- | Provides implementation for @sitemap.xml@. +serveSitemap + :: forall (api :: *). (HasServer api '[], HasSitemap api) + => ServerUrl + -> Proxy api + -> Handler BSL.ByteString +serveSitemap serverUrl proxy = do + sitemap <- toSitemapInfo proxy + pure $ sitemapUrlsToRootLBS serverUrl (urls sitemap) + where + urls x = x ^. sitemapInfoEntries . to (fmap (sitemapEntryToUrlList serverUrl)) + +-- | Provides implementation for nested sitemaps. +serveNestedSitemap + :: forall (api :: *). (HasServer api '[], HasSitemap api) + => ServerUrl + -> Proxy api + -> SitemapIx + -> Handler BSL.ByteString +serveNestedSitemap serverUrl proxy (SitemapIx sitemapIndex) = do + sitemap <- toSitemapInfo proxy + let urls = getUrls sitemap + if urls & concatMap _sitemapUrlLoc & length & (<= 50000) + then throwError err404 + else case Map.lookup sitemapIndex (urlgroups urls) of + Nothing -> throwError err404 + Just content -> pure content + where + getUrls x = x ^. sitemapInfoEntries + . to (fmap (sitemapEntryToUrlList serverUrl)) + . to List.sort + urlgroups xs = sitemapUrlsToSitemapMap serverUrl xs + + +-- ** Both robots.txt and sitemap.xml + +-- | Useful wrapper to extend API with both @robots.txt@ and @sitemap.xml@. +serveWithSeo + :: forall (api :: *). (HasServer api '[], HasRobots api, HasSitemap api) + => ServerUrl + -> Proxy api + -> Server api + -> Application +serveWithSeo serverUrl appProxy appServer = serve extendedProxy extendedServer + where + extendedProxy :: Proxy (RobotsAPI :<|> SitemapAPI :<|> api) + extendedProxy = Proxy + + extendedServer :: Server (RobotsAPI :<|> SitemapAPI :<|> api) + extendedServer = serveRobots serverUrl (toRobots (Proxy :: Proxy (SitemapAPI :<|> api))) + :<|> sitemapServer serverUrl appProxy + :<|> appServer + + + + + diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, module_sources, pkgs) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources