diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for servant-stache + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Tatsuya Hirose (c) 2018 + +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 Tatsuya Hirose 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,18 @@ +# servant-stache +Content-Types and template management for rendering Mustache templates in servant Web applications. This package is heavily inspired by [servant-ede](http://hackage.haskell.org/package/servant-ede). Documentation and examples available at `Servant.Mustache`. + +## Example + +Example code is in `example` directory. You can run example as below. + +```bash +$ git clone git@github.com:lotz84/servant-stache.git +$ cd servant-stache +$ stack build +$ stack exec example +``` + +And access on browser. + +## Contribution +Feel free to send a PR or create a new issue. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +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,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +import GHC.Generics + +import Data.Aeson +import Network.HTTP.Media ((//)) +import qualified Network.Wai.Handler.Warp as Warp +import Servant +import Servant.Mustache + + +-- * For HTML Examle + +data User = User + { name :: String + , age :: Int + } deriving (Generic, ToJSON) + + +-- * For Template Example + +data CSS + +instance Accept CSS where + contentType _ = "text" // "css" + +data CSSData = CSSData + { darken :: Bool + , pageWidth :: Int + } deriving (Generic, ToJSON) + + +-- * Server implementation + +type API = Get '[HTML "user"] User + :<|> "style.css" :> Get '[Template CSS "style"] CSSData + +api :: Proxy API +api = Proxy + +server :: Server API +server = pure (User "lambdabot" 35) + :<|> pure (CSSData True 400) + +main :: IO () +main = do + loadTemplates "example/templates" + putStrLn "Listening on port 8080" + Warp.run 8080 $ serve api server diff --git a/servant-stache.cabal b/servant-stache.cabal new file mode 100644 --- /dev/null +++ b/servant-stache.cabal @@ -0,0 +1,63 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1200df16cf696c0810a2e4953c186a794dfb7646101d651f71ceca33d37305a4 + +name: servant-stache +version: 0.1.0.0 +synopsis: Content-Types for rendering Mustache in servant +description: Content-Types and template management for rendering Mustache templates in servant Web applications. This package is heavily inspired by . Documentation and examples available at "Servant.Mustache". +category: Web +homepage: https://github.com/lotz84/servant-stache#readme +bug-reports: https://github.com/lotz84/servant-stache/issues +author: Tatsuya Hirose +maintainer: tatsuya.hirose.0804@gmail.com +copyright: 2018 Tatsuya Hirose +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/lotz84/servant-stache + +library + exposed-modules: + Servant.Mustache + other-modules: + Paths_servant_stache + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , http-media + , servant + , stache + , text + , transformers + , unordered-containers + , vector + , xss-sanitize + default-language: Haskell2010 + +executable example + main-is: Main.hs + other-modules: + Paths_servant_stache + hs-source-dirs: + example + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , http-media + , servant-server + , servant-stache + , warp + default-language: Haskell2010 diff --git a/src/Servant/Mustache.hs b/src/Servant/Mustache.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Mustache.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Servant.Mustache +-- Copyright : (c) Tatsuya Hirose 2018 +-- Maintainer : tatsuya.hirose.0804@gmail.com +-- Stability : experimental +-- +-- Rendering Mustache templates with +-- using . This package is heavily +-- inspired by . +-- +-- This package provides two Content-Types with servant (i.e just like 'JSON'), +-- 'HTML' and 'Template'. +-- +-- +-- - 'HTML' takes a filename as parameter and lets you render the template +-- with that name against the data returned by a request handler using +-- the @text\/html;charset=utf-8@ MIME type, XSS-sanitizing the said data +-- along the way. +-- - 'Template' does the same except that it's parametrized over the content type +-- to be sent along with the rendered template. Any type that has an 'Accept' +-- instance will do. +----------------------------------------------------------------------------- +module Servant.Mustache + ( -- * Content-Types + HTML + , Template + + -- * Loading template files + , loadTemplates +) where + +import Data.Proxy (Proxy(..)) +import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar) +import GHC.TypeLits (KnownSymbol(..), Symbol, symbolVal) +import System.IO.Unsafe (unsafePerformIO) + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Aeson +import qualified Data.HashMap.Strict as HM +import Data.Text (Text, pack) +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Vector as V +import Network.HTTP.Media ((//), (/:)) +import Servant.API.ContentTypes (Accept(..), MimeRender(..)) +import Text.HTML.SanitizeXSS (sanitize) +import qualified Text.Mustache as Stache + + +-- global store of templates +{-# NOINLINE __template_store #-} +__template_store :: MVar Stache.Template +__template_store = unsafePerformIO newEmptyMVar + + +-- | This function initializes a global template store +-- and fills it with the resulting compiled templates. +-- This function /does not/ scan the directory recursively. +-- +-- /IMPORTANT/: Must /always/ be called before starting your /servant/ application. +-- +loadTemplates :: (MonadIO io) => FilePath -> io () +loadTemplates dir = do + template <- Stache.compileMustacheDir undefined dir + liftIO $ putMVar __template_store template + + +-- | A generic template for any content, parametrized over the +-- content-type (or MIME) associated to the template. +-- +-- The first parameter is the content-type you want to send along with +-- rendered templates (must be an instance of 'Accept'). The second +-- parameter is the name of (or path to) the template file. Any type +-- used with this content-type (like @CSSData@ below) must have an +-- instance of the 'ToJSON' class. +-- +-- Here is how you could render and serve, say, /CSS/ +-- (Cascading Style Sheets) templates that make use +-- of some @CSSData@ data type to tweak the styling. +-- +-- @ +-- data CSS +-- +-- instance Accept CSS where +-- contentType _ = "text" // "css" +-- +-- data CSSData = CSSData +-- { darken :: Bool +-- , pageWidth :: Int +-- } deriving (Generic, ToJSON) +-- +-- type StyleAPI = "style.css" :> Get '[Template CSS "style"] CSSData +-- @ +-- +-- @style.mustache@ could for example be: +-- +-- > body { +-- > {{#darken}} +-- > background-color: #222; +-- > color: blue; +-- > {{/darken}} +-- > {{^darken}} +-- > background-color: white; +-- > color: back; +-- > {{/darken}} +-- > } +-- > +-- > #content { +-- > width: {{pageWidth}}px; +-- > margin: 0 auto; +-- > } +-- +-- A complete, runnable version of this can be found +-- in the @examples@ folder of the git repository +data Template (ct :: *) (file :: Symbol) + +-- | use @ct@'s content-type +instance Accept ct => Accept (Template ct file) where + contentType _ = contentType ctproxy + where ctproxy = Proxy :: Proxy ct + +-- | render the contents of @file@ in the global template store +instance (KnownSymbol file, Accept ct, ToJSON a) => MimeRender (Template ct file) a where + mimeRender _ val = + encodeUtf8 $ Stache.renderMustache template (toJSON val) + where template = tstore { Stache.templateActual = Stache.PName (pack filename) } + filename = symbolVal (Proxy :: Proxy file) + tstore = unsafePerformIO (readMVar __template_store) + + +-- | 'HTML' content type. 'HTML' takes a type-level string +-- which is a filename for the template you want to use +-- to render values. Types used with the 'HTML' content +-- type (like @User@ below) must provide a 'ToJSON' instance. +-- +-- The filename doesn't contain any extension. For example, if +-- the template filename is @user.mustache@, `HTML` takes @user@ +-- as filename. +-- +-- @ +-- data User = User { name :: String, age :: Int } deriving (Generic, ToJSON) +-- +-- type UserAPI = "user" :> Get '[HTML "user"] User +-- +-- userAPI :: Proxy UserAPI +-- userAPI = Proxy +-- +-- server :: Server API +-- server = pure (User "lambdabot" 31) +-- +-- main :: IO () +-- main = do +-- loadTemplates "./templates" +-- run 8080 (serve userAPI server) +-- @ +-- +-- This will look for a template at @.\/templates\/user.mustache@, which could +-- for example be: +-- +-- >
    +-- >
  • Name: {{ name }}
    • +-- >
  • Age: {{ age }}
    • +-- >
+-- +-- /IMPORTANT/: it XSS-sanitizes every bit of text in the 'Value' +-- passed to the template. +data HTML (file :: Symbol) + +-- | @text/html;charset=utf-8@ +instance Accept (HTML file) where + contentType _ = "text" // "html" /: ("charset", "utf-8") + +-- | XSS-sanitizes data before rendering it +instance (KnownSymbol file, ToJSON a) => MimeRender (HTML file) a where + mimeRender _ val = mimeRender (Proxy :: Proxy (Template (HTML file) file)) $ + sanitizeValue (toJSON val) + +sanitizeObject :: Object -> Object +sanitizeObject = HM.fromList . map sanitizeKV . HM.toList + +sanitizeKV :: (Text, Value) -> (Text, Value) +sanitizeKV (k, v) = (sanitize k, sanitizeValue v) + +sanitizeValue :: Value -> Value +sanitizeValue (String s) = String (sanitize s) +sanitizeValue (Array a) = Array (V.map sanitizeValue a) +sanitizeValue (Object o) = Object (sanitizeObject o) +sanitizeValue x = x