diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# 0.9 + +- Also accept content type without character set i.e `text/html` + +# 0.8.1 + +- Support `servant-0.14` +- Add `Lucid.Servant` with `safeHref_` function and its variants. + +# 0.8 + +- Only single `MimeRender HTML a` instance. `lucid-2.9.8` has `ToHtml (HtmlT m a)` instance. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,58 @@ +-- ConstraintKinds needed only for 7.8.4 +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Main (main) where + +import Data.Maybe + (fromMaybe) +import Lucid +import Lucid.Servant +import Network.Wai + (Application) +import Servant +import Servant.HTML.Lucid +import System.Environment + (getArgs, lookupEnv) +import Text.Read + (readMaybe) + +import qualified Network.Wai.Handler.Warp as Warp + +type API = "string" :> Get '[HTML] String + :<|> "nested" :> "html" :> Get '[HTML] (Html ()) + +api :: Proxy API +api = Proxy + +apiLink_ + :: (IsElem endpoint API, HasLink endpoint) + => Proxy endpoint -> MkLink endpoint Attribute +apiLink_ = safeAbsHref_ (Proxy :: Proxy API) + +stringLink_ :: Attribute +stringLink_ = apiLink_ (Proxy :: Proxy ("string" :> Get '[HTML] String)) + +server :: Server API +server = return "example" :<|> return html where + html :: Html () + html = do + p_ $ b_ "bar" + p_ $ i_ "iik" + p_ $ a_ [stringLink_] "string" + +app :: Application +app = serve api server + +main :: IO () +main = do + args <- getArgs + case args of + ("run":_) -> do + port <- fmap (fromMaybe 8000 . (>>= readMaybe)) (lookupEnv "PORT") + putStrLn $ "http://localhost:" ++ show port ++ "/" + Warp.run port app + _ -> do + putStrLn "Example application, used as a compilation check" + putStrLn "To run, pass run argument: --test-arguments run" diff --git a/servant-lucid.cabal b/servant-lucid.cabal --- a/servant-lucid.cabal +++ b/servant-lucid.cabal @@ -1,32 +1,58 @@ --- Initial servant-lucid.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - +cabal-version: >=1.10 name: servant-lucid -version: 0.4.4.7 +version: 0.9.0.6 + synopsis: Servant support for lucid --- description: -homepage: http://haskell-servant.github.io/ +description: + Servant support for lucid. + . + 'HTML' content type which will use `ToHtml` class. + . + Lucid.Servant uses `Link` rather than `Text` for safe 'href' attributes. + +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant-lucid/issues license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: -category: Web +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2018 Servant Contributors +category: Web, Servant build-type: Simple --- extra-source-files: -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues +extra-source-files: CHANGELOG.md +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 + source-repository head type: git - location: http://github.com/haskell-servant/servant.git + location: http://github.com/haskell-servant/servant-lucid.git library exposed-modules: Servant.HTML.Lucid - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , http-media - , lucid - , servant == 0.4.* + Lucid.Servant + build-depends: base >=4.9 && <5 + , http-media >=0.6.4 && <0.9 + , lucid >=2.9.8 && <2.12 + , text >=1.2.3.0 && <1.3 || >= 2 && < 2.1 + , servant >=0.17 && <0.20 + + if !impl(ghc >= 8.0) + build-depends: semigroups >=0.18.4 && <0.20 + hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall + +test-suite example + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + example + ghc-options: -Wall + build-depends: + base + , lucid + , servant-lucid + , servant-server >=0.14 && <0.20 + , wai >=3.0.3.0 && <3.3 + , warp >=3.0.13.1 && <3.4 + default-language: Haskell2010 diff --git a/src/Lucid/Servant.hs b/src/Lucid/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Lucid/Servant.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Some helper functions for creating values in +-- [lucid](https://hackage.haskell.org/package/lucid) DSLs that work +-- with [servant](https://hackage.haskell.org/package/servant). +module Lucid.Servant ( + safeHref_, + safeAbsHref_, + safeRelHref_, + linkHref_, + linkAbsHref_, + linkRelHref_, + ) where + +import Data.Proxy + (Proxy) +import Data.Semigroup + ((<>)) +import qualified Data.Text as T +import Lucid + (Attribute) +import Lucid.Html5 + (href_) +import Servant.API + (toUrlPiece) +import Servant.Links + (HasLink, IsElem, Link, MkLink, safeLink') + +-- | 'safeLink' variant which creates lucid's 'Attribute' given base url. +-- +-- >>> type API = "path" :> Get '[JSON] Int +-- >>> let api = Proxy :: Proxy API +-- +-- >>> safeHref_ "" api api +-- Attribute "href" "path" +-- +-- >>> safeHref_ "/" api api +-- Attribute "href" "/path" +-- +-- >>> safeHref_ "http://example.com" api api +-- Attribute "href" "http://example.com/path" +-- +-- >>> safeHref_ "http://example.com/" api api +-- Attribute "href" "http://example.com/path" +-- +safeHref_ + :: (IsElem endpoint api, HasLink endpoint) + => T.Text + -> Proxy api -> Proxy endpoint -> MkLink endpoint Attribute +safeHref_ = safeLink' . linkHref_ + +-- | @'safeLink' "/"@ +safeAbsHref_ + :: (IsElem endpoint api, HasLink endpoint) + => Proxy api -> Proxy endpoint -> MkLink endpoint Attribute +safeAbsHref_ = safeLink' linkAbsHref_ + +-- | @'safeLink' ""@ +safeRelHref_ + :: (IsElem endpoint api, HasLink endpoint) + => Proxy api -> Proxy endpoint -> MkLink endpoint Attribute +safeRelHref_ = safeLink' linkRelHref_ + +-- | Create an `href` attribute from a 'Link', with given base url. +-- +-- "servant" ensures that any 'Link' is valid within an API. +-- This function ensures it is possible to navigate to that endpoint from +-- a page which shares a root with that API. +linkHref_ :: T.Text -> Link -> Attribute +linkHref_ burl = href_ . (burl <+>) . toUrlPiece + +-- | Create an `href` attribute from a 'Link', with leading '/'. +-- +-- "servant" ensures that any 'Link' is valid within an API. +-- This function ensures it is possible to navigate to that endpoint from +-- a page which shares a root with that API. +linkAbsHref_ :: Link -> Attribute +linkAbsHref_ = linkHref_ "/" + +-- | Create an `href` attribute from a 'Link', as a relative link. +-- +-- "servant" ensures that any 'Link' is valid within an API. +-- Use this function if a relative link (no leading '/') is required. +linkRelHref_ :: Link -> Attribute +linkRelHref_ = href_ . toUrlPiece + +(<+>) :: T.Text -> T.Text -> T.Text +burl <+> path + | T.null burl = path + | T.last burl == '/' = burl <> path + | otherwise = burl <> "/" <> path + +-- $setup +-- +-- >>> :set -XOverloadedStrings -XDataKinds -XTypeOperators +-- >>> import Servant.API +-- >>> import Data.Proxy (Proxy (..)) +-- diff --git a/src/Servant/HTML/Lucid.hs b/src/Servant/HTML/Lucid.hs --- a/src/Servant/HTML/Lucid.hs +++ b/src/Servant/HTML/Lucid.hs @@ -3,9 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. @@ -17,8 +14,9 @@ -- Will then check that @a@ has a `ToHtml` instance, or is `Html`. module Servant.HTML.Lucid where +import qualified Data.List.NonEmpty as NE import Data.Typeable (Typeable) -import Lucid (Html, ToHtml (..), renderBS) +import Lucid (ToHtml (..), renderBS) import qualified Network.HTTP.Media as M import Servant.API (Accept (..), MimeRender (..)) @@ -26,18 +24,9 @@ -- | @text/html;charset=utf-8@ instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") + contentTypes _ = + "text" M.// "html" M./: ("charset", "utf-8") NE.:| + ["text" M.// "html"] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ToHtml a => MimeRender HTML a where +instance ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender HTML (Html a) where - mimeRender _ = renderBS