packages feed

dani-servant-lucid2 (empty) → 0.1.0.0

raw patch · 6 files changed

+209/−0 lines, 6 filesdep +basedep +dani-servant-lucid2dep +http-media

Dependencies added: base, dani-servant-lucid2, http-media, http-types, lucid2, servant, servant-server

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for dani-servant-lucid2++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Daniel Díaz++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 Daniel Díaz 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.
+ dani-servant-lucid2.cabal view
@@ -0,0 +1,59 @@+cabal-version:      3.4+name:               dani-servant-lucid2+version:            0.1.0.0+synopsis:           Servant support for lucid2+description:+  Servant support for lucid2.+   +  'HTML' content type backed by the `ToHtml` typeclass.+homepage:           https://github.com/danidiaz/dani-servant-lucid2+license:            BSD-3-Clause+license-file:       LICENSE+author:             Daniel Díaz+maintainer:         diaz_carrete@yahoo.com+-- copyright:+category:           Web+build-type:         Simple+extra-doc-files:    CHANGELOG.md+-- extra-source-files:+tested-with: GHC==9.8.1 GHC==9.2.8+source-repository    head+    type:     git+    location: https://github.com/danidiaz/dani-servant-lucid2.git++common basic+    ghc-options: -Wall+    default-language: GHC2021+    build-depends:    +        base >=4.9 && <5,+        http-media >= 0.8.1 && < 0.9,+        lucid2 >= 0.0.20230706 && < 0.1,++library+    import: basic+    exposed-modules:  +        Servant.API.ContentTypes.Lucid+    hs-source-dirs:   lib+    build-depends:    +        servant >= 0.20.1 && < 0.21,++library server+    import: basic+    exposed-modules:  +        Servant.Server.Lucid+    hs-source-dirs: lib-server+    build-depends:    +        servant-server >= 0.20 && < 0.21,+        http-types >= 0.12.4 && < 0.13,+    visibility: public++test-suite tests+    import:           basic+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          tests.hs+    build-depends:    +        lucid2,+        dani-servant-lucid2,+        dani-servant-lucid2:server,+        servant-server >= 0.20 && < 0.21,
+ lib-server/Servant/Server/Lucid.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module Servant.Server.Lucid+  ( htmlResponse,+    htmlResponse',+  )+where++import Lucid (Html, ToHtml (..), renderBS)+import Network.HTTP.Types.Header+import Servant.Server++-- | Build a 'ServerError' with an HTML body.+--+-- Note that 'ServerError's, despite their name, can represent any type of+-- response, including successful ones.+htmlResponse ::+  -- | HTTP response status code+  Int ->+  [Header] ->+  Html () ->+  ServerError+htmlResponse = htmlResponse'++-- | More general version of 'htmlResponse', that can have worse type+-- inference.+htmlResponse' ::+  (ToHtml a) =>+  -- | HTTP response status code+  Int ->+  [Header] ->+  a ->+  ServerError+htmlResponse' errHTTPCode extraHeaders a =+  ServerError+    { errHTTPCode,+      errReasonPhrase = "",+      errBody = renderBS (toHtml a),+      errHeaders =+        [("Content-Type", "text/html;charset=utf-8")] ++ extraHeaders+    }
+ lib/Servant/API/ContentTypes/Lucid.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Module copied and adapted from https://hackage.haskell.org/package/servant-lucid-0.9.0.6+--+-- An @HTML@ empty data type with 'Servant.API.MimeRender' instances for+-- any type which is an instance of @lucid2@'s 'Lucid.ToHtml':+--+-- >>> type Example = Get '[HTML] a+--+-- (Here the type @a@ should have a 'Lucid.ToHtml' instance.)+module Servant.API.ContentTypes.Lucid+  ( HTML,+  )+where++import Data.List.NonEmpty qualified as NE+import Data.Typeable (Typeable)+import Lucid (ToHtml (..), renderBS)+import Network.HTTP.Media qualified as M+import Servant.API (Accept (..), MimeRender (..))++data HTML deriving stock (Typeable)++-- | @text/html;charset=utf-8@+instance Accept HTML where+  contentTypes _ =+    "text" M.// "html" M./: ("charset", "utf-8")+      NE.:| ["text" M.// "html"]++instance (ToHtml a) => MimeRender HTML a where+  mimeRender _ = renderBS . toHtml
+ test/tests.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Lucid (Html, ToHtml (..), div_)+import Servant+import Servant.API.ContentTypes.Lucid (HTML)+import Servant.Server.Lucid (htmlResponse, htmlResponse')++type API = "foo" :> Get '[HTML] (Html ())++server :: Server API+server = do+  let response =+        -- this is ambiguous:+        -- htmlResponse' 200 []+        htmlResponse 200 [] $ div_ "foo"+  throwError response++server' :: Server API+server' = do+  let response =+        -- We need the type application+        htmlResponse' @(Html ()) 200 [] $ div_ "foo"+  throwError response++data Foo = Foo++instance ToHtml Foo where+  toHtml Foo = div_ "foo"+  toHtmlRaw Foo = div_ "foo"++serverFoo :: Server API+serverFoo = do+  let response =+        -- No neet for type application here.+        htmlResponse' 200 [] Foo+  throwError response++main :: IO ()+main = pure ()