servant-lucid 0.7.1 → 0.9.0.6
raw patch · 6 files changed
Files
- CHANGELOG.md +12/−0
- example/Main.hs +58/−0
- include/overlapping-compat.h +0/−8
- servant-lucid.cabal +42/−18
- src/Lucid/Servant.hs +99/−0
- src/Servant/HTML/Lucid.hs +6/−10
+ CHANGELOG.md view
@@ -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.
+ example/Main.hs view
@@ -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"
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-lucid.cabal view
@@ -1,34 +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.7.1+version: 0.9.0.6+ synopsis: Servant support for lucid--- description:+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: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2015-2016 Servant Contributors-category: Web+copyright: 2015-2018 Servant Contributors+category: Web, Servant build-type: Simple-extra-source-files: include/*.h-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.7.*+ 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- include-dirs: include 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
+ src/Lucid/Servant.hs view
@@ -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 (..))+--
src/Servant/HTML/Lucid.hs view
@@ -4,8 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#include "overlapping-compat.h"- -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. -- You should only need to import this module for it's instances and the@@ -16,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 (..)) @@ -25,12 +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 OVERLAPPABLE_- ToHtml a => MimeRender HTML a where+instance ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml--instance OVERLAPPING_- MimeRender HTML (Html a) where- mimeRender _ = renderBS