packages feed

servant-ede 0.4.0.1 → 0.5

raw patch · 14 files changed

+602/−696 lines, 14 filesdep +vectordep +xss-sanitizedep ~aesondep ~bytestringdep ~ede

Dependencies added: vector, xss-sanitize

Dependency ranges changed: aeson, bytestring, ede, either, filepath, http-media, http-types, semigroups, servant, servant-server, text, transformers, unordered-containers, wai

Files

README.md view
@@ -1,3 +1,3 @@ # servant-ede -Support ede templates in servant. See the documentation of the `Servant.HTML.EDE` module for examples and explanations.+Support ede templates in servant. See the documentation of the `Servant.EDE` module for examples and explanations, [on hackage](http://hackage.haskell.org/package/servant-ede).
example/example.hs view
@@ -5,29 +5,60 @@ import Control.Monad import Data.Monoid import GHC.Generics+import Network.HTTP.Media ((//)) import Network.Wai.Handler.Warp import Servant-import Servant.HTML.EDE-import Text.EDE+import Servant.EDE +-- * Using 'Tpl' for rendering CSS templates++data CSS++instance Accept CSS where+  contentType _ = "text" // "css"++type StyleAPI = "style.css" :> Get '[Tpl CSS "style.tpl"] CSSData++data CSSData = CSSData+  { darken :: Bool+  , pageWidth :: Int+  } deriving Generic++instance ToObject CSSData++styleServer :: Server StyleAPI+styleServer = -- FOR NOW+  return (CSSData True 400)++-- * Using 'HTML' for HTML template rendering+ data User = User { name :: String, age :: Int }   deriving (Eq, Show, Generic)  instance ToObject User where -type API = "index" :> Tpl "index.tpl"-      :<|> "foo"   :> Tpl "foo.tpl"-      :<|> "user"  :> Get '[HTML "user.tpl"] User+type UserAPI = "user" :> Get '[HTML "user.tpl"] User -api :: Proxy API-api = Proxy+userServer :: Server UserAPI+userServer = return (User "lambdabot" 35) -server :: Server API-server = rawTemplate :<|> rawTemplate :<|> return (User "lambdabot" 35)+type API = StyleAPI :<|> UserAPI -  where rawTemplate = return mempty+api :: Proxy API+api = Proxy  main :: IO () main = do   loadTemplates api "example"-  run 8082 (serve api server)+  run 8082 (serve api $ styleServer :<|> userServer)++-- You can now head to:+-- http://localhost:8082/user+-- and+-- http://localhost:8082/style.css+-- to see 'HTML' and 'Tpl' + 'CSS' in action,+-- respectively.+--+-- Feel free to tweak the content of the template files+-- as well as the 'User' and 'CSSData' values in this program+-- to see how it affects the rendering.
servant-ede.cabal view
@@ -1,14 +1,12 @@--- Initial servant-ede.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/- name:                servant-ede-version:             0.4.0.1+version:             0.5 synopsis:            Combinators for rendering EDE templates in servant web applications description:   Combinators for rendering EDE templates in servant web applications.   .-  Documentation and examples available at "Servant.HTML.EDE".+  Documentation and examples available at "Servant.EDE". homepage:            http://github.com/alpmestan/servant-ede+bug-reports:         http://github.com/alpmestan/servant-ede/issues license:             BSD3 license-file:        LICENSE author:              Alp Mestanogullari@@ -18,32 +16,35 @@ build-type:          Simple extra-source-files:  README.md cabal-version:       >=1.10+source-repository head+  type: git+  location: git://github.com/alpmestan/servant-ede.git  library-  exposed-modules:     Servant.HTML.EDE-  other-modules:-      Servant.HTML.EDE.Internal-    , Servant.HTML.EDE.Internal.Reify-    , Servant.HTML.EDE.Internal.Templates-    , Servant.HTML.EDE.Internal.ToObject-    , Servant.HTML.EDE.Internal.Validate+  exposed-modules:+      Servant.EDE+    , Servant.EDE.Internal+    , Servant.EDE.Internal.Reify+    , Servant.EDE.Internal.ToObject+    , Servant.EDE.Internal.Validate    build-depends:-      aeson >= 0.8+      aeson >= 0.8 && <0.10     , base >=4.7 && <5-    , bytestring >= 0.10-    , filepath >= 1.2-    , ede >= 0.2-    , either >= 4-    , http-media >= 0.6-    , http-types >= 0.8-    , semigroups >= 0.16-    , servant >= 0.4-    , servant-server >= 0.4-    , text >= 1.0-    , transformers >= 0.4-    , unordered-containers >= 0.2-    , wai >= 3.0+    , bytestring >= 0.10 && <0.11+    , filepath >= 1.2 && <1.5+    , ede >= 0.2 && <0.3+    , either >= 4.0 && <4.5+    , http-media >= 0.6 && <0.7+    , http-types >= 0.8 && <0.9+    , semigroups >= 0.16 && <0.17+    , servant >= 0.4 && <0.5+    , text >= 1.0 && <1.3+    , transformers >= 0.4 && <0.5+    , unordered-containers >= 0.2 && <0.3+    , vector >= 0.9 && <0.11+    , wai >= 3.0 && <3.1+    , xss-sanitize >= 0.3 && <0.4    ghc-options:         -O2 -Wall   hs-source-dirs:      src@@ -57,6 +58,7 @@   build-depends:       base >= 4.7 && <5     , ede+    , http-media     , servant-server     , servant-ede     , warp >= 3.0
+ src/Servant/EDE.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Servant.EDE+-- Copyright   :  (c) Alp Mestanogullari 2015+-- Maintainer  :  alpmestan@gmail.com+-- Stability   :  experimental+--+-- Rendering EDE templates with servant.+--+-- This package provides two combinators to be used as content-types+-- with servant (i.e just like 'JSON'), 'HTML' and 'Tpl'.+--+-- - '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. See 'HTML' for an example.+-- - 'Tpl' 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. See 'Tpl' for an example.+-----------------------------------------------------------------------------+module Servant.EDE+  ( -- * Combinators+    HTML+  , Tpl++    -- * Sending Haskell data to templates+  , ToObject(..)++  , -- * Loading template files (mandatory)+    loadTemplates+  , TemplateFiles+  , Reify+  , Templates+  , Errors+  , TemplateError+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Traversable (traverse)+#endif++import Control.Concurrent+import Control.Monad.IO.Class+import Data.Aeson (Object, Value(..))+import Data.Foldable (fold)+import Data.HashMap.Strict (HashMap, (!))+import Data.Proxy+import Data.Semigroup+import Data.Text (Text)+import Data.Text.Lazy.Encoding (encodeUtf8)+import GHC.TypeLits+import Network.HTTP.Media hiding (Accept)+import Servant.API+import Servant.EDE.Internal.Reify+import Servant.EDE.Internal.ToObject+import Servant.EDE.Internal.Validate+import System.FilePath+import System.IO.Unsafe+import Text.EDE+import Text.HTML.SanitizeXSS++import qualified Data.HashMap.Strict as HM+import qualified Data.Vector         as V++-- | This function initializes a global+--   template store (i.e a 'Templates' value) and fills it with+--   the resulting compiled templates if all of them are compiled+--   successfully. If that's not the case, the global template store+--   (under an 'MVar') is left empty.+--+--   /IMPORTANT/: Must /always/ be called before starting your /servant/ application. Example:+--+-- > type API = Get '[HTML "home.tpl"] HomeData+-- >+-- > api :: Proxy API+-- > api = Proxy+-- >+-- > main :: IO ()+-- > main = loadTemplates api "path/to/templates" >>= print+--+-- This would try to load @home.tpl@, printing any error or+-- registering the compiled template in a global (but safe)+-- compiled template store, if successfully compiled.+loadTemplates :: (Reify (TemplateFiles api), Applicative m, MonadIO m)+              => Proxy api+              -> FilePath -- ^ root directory for the templates+              -> m Errors+loadTemplates proxy dir = do+  res <- loadTemplates' proxy dir+  case res of+    Left errs  -> return errs+    Right tpls -> do+      liftIO $ putMVar __template_store tpls+      return []++loadTemplates' :: (Reify (TemplateFiles api), Applicative m, MonadIO m)+               => Proxy api+               -> FilePath   -- ^ root directory for the templates+               -> m (Either Errors Templates)+loadTemplates' proxy templatedir =+  fmap (eitherValidate . fmap fold) . runValidateT $+    traverse (processFile templatedir) files++  where files :: [FilePath]+        files = templateFiles proxy++-- | A generic template combinator, 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.+--   It must live under the 'FilePath' argument of 'loadTemplates'.+--+--   Any type used with this content-type (like @CSSData@ below)+--   must have an instance of the 'ToObject' class. The field names+--   become the variable names in the template world.+--+--   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"+--+-- type StyleAPI = "style.css" :> Get '[Tpl CSS "style.tpl"] CSSData+--+-- styleAPI :: Proxy StyleAPI+-- styleAPI = Proxy+--+-- data CSSData = CSSData+--   { darken :: Bool+--   , pageWidth :: Int+--   } deriving Generic+--+-- instance ToObject CSSData+--+-- server :: Server API+-- server = -- produce a CSSData value depending on whatever is relevant...+--+-- main :: IO ()+-- main = do+--   loadTemplates styleAPI "./templates"+--   run 8082 (serve styleAPI server)+-- @+--+-- This will look for a template at @.\/templates\/style.tpl@,+-- which could for example be:+--+-- > body {+-- >   {% if darken %}+-- >   background-color: #222222;+-- >   color: blue;+-- >   {% else %}+-- >   background-color: white;+-- >   color: back;+-- >   {% endif %}+-- > }+-- >+-- > #content {+-- >   width: {{ pageWidth }};+-- >   margin: 0 auto;+-- > }+--+-- A complete, runnable version of this can be found+-- in the @examples@ folder of the git repository.+data Tpl (ct :: *) (file :: Symbol)++-- the filename doesn't matter for the content type,+-- as long as 'ct' is a valid one (html, json, css, etc or application-specific)+instance Accept ct => Accept (Tpl ct file) where+  contentType _ = contentType ctproxy+    where ctproxy = Proxy :: Proxy ct++instance (KnownSymbol file, Accept ct, ToObject a) => MimeRender (Tpl ct file) a where+  mimeRender _ val = encodeUtf8 . result (error . show) id $+    render templ (toObject val)++    where templ = tmap ! filename+          filename = symbolVal (Proxy :: Proxy file)+          tmap = templateMap $ unsafePerformIO (readMVar __template_store)++__template_store :: MVar Templates+__template_store = unsafePerformIO newEmptyMVar++-- | 'HTML' content type, but more than just that.+--+--   'HTML' takes a type-level string which is+--   a filename for the template you want to use to+--   render values. Just like 'Tpl', types used with+--   the 'HTML' content type (like @User@ below)+--   must provide a 'ToObject' instance.+--+--   Example:+--+-- @+-- type UserAPI = "user" :> Get '[JSON, HTML "user.tpl"] User+--+-- userAPI :: Proxy UserAPI+-- userAPI = Proxy+--+-- data User = User { name :: String, age :: Int } deriving Generic+--+-- instance ToObject User+--+-- server :: Server API+-- server = return (User "lambdabot" 31)+--+-- main :: IO ()+-- main = do+--   loadTemplates userAPI "./templates"+--   run 8082 (serve userAPI server)+-- @+--+-- This will look for a template at @.\/templates\/user.tpl@, which could+-- for example be:+--+-- > <ul>+-- >   <li><strong>Name:</strong> {{ name }}</li>+-- >   <li><strong>Age:</strong> {{ age }}</li>+-- > </ul>+--+-- /IMPORTANT/: it XSS-sanitizes every bit of text in the 'Object'+-- 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, ToObject a) => MimeRender (HTML file) a where+  mimeRender _ val = mimeRender (Proxy :: Proxy (Tpl (HTML file) file)) $+    sanitizeObject (toObject 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++type family Append (xs :: [k]) (ys :: [k]) :: [k] where+  Append '[]       ys = ys+  Append (x ': xs) ys = x ': Append xs ys++type family Member (x :: k) (xs :: [k]) :: Bool where+  Member x (x ': xs) = 'True+  Member x (y ': xs) = Member x xs+  Member x       '[] = 'False++-- | Collect all the template filenames of an API as a type-level+--   list of strings, by simply looking at all occurences of the+--   'Tpl' and 'HTML' combinators and keeping the filenames associated to them.+type family TemplateFiles (api :: k) :: [Symbol]+type instance TemplateFiles (a :<|> b)    = Append (TemplateFiles a) (TemplateFiles b)+type instance TemplateFiles (a :> r)      = TemplateFiles r+type instance TemplateFiles (Delete cs a) = CTFiles cs+type instance TemplateFiles (Get cs a)    = CTFiles cs+type instance TemplateFiles (Patch cs a)  = CTFiles cs+type instance TemplateFiles (Post cs a)   = CTFiles cs+type instance TemplateFiles (Put cs a)    = CTFiles cs+type instance TemplateFiles Raw           = '[]++type family CTFiles (cts :: [*]) :: [Symbol] where+  CTFiles '[]        = '[]+  CTFiles (c ': cts) = Append (CTFile c) (CTFiles cts)++type family CTFile c :: [Symbol] where+  CTFile (HTML fp)   = '[fp]+  CTFile (Tpl ct fp) = '[fp]+  CTFile a           = '[]++templates :: Proxy api -> Proxy (TemplateFiles api)+templates Proxy = Proxy++templateFiles :: Reify (TemplateFiles api) => Proxy api -> [FilePath]+templateFiles = reify . templates++-- | An opaque "compiled-template store".+--+-- The only way to get a value of this type is to use+-- 'Servant.EDE.loadTemplates' on a proxy of your API.+--+-- This ensures that when we lookup a template (in order+-- to render it) in our 'Templates' store, we are+-- guaranteed to find it.+newtype Templates = Templates (HashMap String Template)+  deriving Eq++templateMap :: Templates -> HashMap String Template+templateMap (Templates m) = m++instance Semigroup Templates where+  Templates a <> Templates b = Templates (a <> b)++instance Monoid Templates where+  mempty = Templates mempty++  a `mappend` b = a <> b++tpl :: FilePath -> Template -> Templates+tpl fp t = Templates $ HM.singleton fp t++-- | A 'TemplateError' is a pair of a template filename+--   and the error string for that file.+type TemplateError = (FilePath, String)++-- | A list of 'TemplateError's.+type Errors = [TemplateError]++err :: Show a => FilePath -> a -> Errors+err fp d = [(fp, show d)]++processFile :: MonadIO m => FilePath -> FilePath -> ValidateT Errors m Templates+processFile d fp = validate . liftIO $ parseFile' (d </> fp)++  where parseFile' f = fmap validateResult (parseFile f)+        validateResult (Success t) = OK (tpl fp t)+        validateResult (Failure e) = NotOK (err fp e)
+ src/Servant/EDE/Internal.hs view
@@ -0,0 +1,10 @@+module Servant.EDE.Internal+  ( module Servant.EDE.Internal.Reify+  , module Servant.EDE.Internal.ToObject+  , module Servant.EDE.Internal.Validate+  ) where++import Servant.EDE.Internal.Reify+import Servant.EDE.Internal.ToObject+import Servant.EDE.Internal.Validate+
+ src/Servant/EDE/Internal/Reify.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.EDE.Internal.Reify (Reify(..)) where++import Data.Proxy+import GHC.TypeLits++-- | Helper class to reify a type-level list of strings+--   into a value-level list of string. Used to turn+--   the type-level list of template file names into+--   a value-level list.+class Reify (symbols :: [Symbol]) where+  reify :: Proxy symbols -> [String]++instance Reify '[] where+  reify _ = []++instance (KnownSymbol s, Reify symbols)+      => Reify (s ': symbols) where+  reify _ = symbolVal ps : reify psymbols++    where ps = Proxy :: Proxy s+          psymbols = Proxy :: Proxy symbols
+ src/Servant/EDE/Internal/ToObject.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE OverloadedStrings #-}+module Servant.EDE.Internal.ToObject where++import Data.Aeson+import Data.HashMap.Strict+import Data.Monoid+import Data.Text+import GHC.Generics++-- | Turn haskell values into JSON objects.+--+-- This is the mechanism used by EDE to marshall data from Haskell+-- to the templates. The rendering is then just about feeding the+-- resulting 'Object' to a compiled 'Template'. Example:+--+-- > import Text.EDE+-- >+-- > data User = User { name :: String, age :: Int }+-- >+-- > instance ToObject User where+-- >   toObject user =+-- >     fromPairs [ "name" .= name user+-- >               , "age"  .= age user+-- >               ]+--+-- However, you're not forced to write the instance yourself for such a type.+-- Indeed, for any record type (i.e a datatype with a single constructor and+-- with field selectors) you can let @GHC.Generics@ derive the 'ToObject' instance+-- for you.+--+-- > data User = User { name :: String, age :: Int } deriving Generic+-- > instance ToObject User+--+-- This will generate an equivalent instance to the previous one.+class ToObject a where++  -- | Turn values of type @a@ into JSON 'Object's.+  --+  -- @ +  -- -- Reminder:+  -- type Object = 'HashMap' 'Text' 'Value'+  -- @+  toObject :: a -> Object+  +  default toObject :: (Generic a, GToObject (Rep a)) => a -> Object+  toObject = genericToObject++instance ToObject (HashMap Text Value) where+  toObject = id++class GToObject f where+  gtoObject :: f a -> Object++instance GToObject V1 where+  gtoObject _ = mempty++instance GToObject U1 where+  gtoObject U1 = mempty++instance (GToObject f, GToObject g)+      => GToObject (f :*: g) where+  gtoObject (f :*: g) = gtoObject f <> gtoObject g++instance GToObject a => GToObject (M1 D d a) where+  gtoObject (M1 x) = gtoObject x++instance GToObject a => GToObject (M1 C c a) where+  gtoObject (M1 x) = gtoObject x++instance (Selector s, ToJSON a) => GToObject (M1 S s (K1 r a)) where+  gtoObject s@(M1 (K1 x)) = fromList [(fieldname, value)]+    where fieldname = pack (selName s)+          value     = toJSON x++genericToObject :: (Generic a, GToObject (Rep a)) => a -> Object+genericToObject = gtoObject . from
+ src/Servant/EDE/Internal/Validate.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+module Servant.EDE.Internal.Validate where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Foldable+import Data.Traversable+#endif++import Data.Functor.Compose+import Data.Semigroup++data Validated e a = OK a | NotOK e+  deriving (Eq, Show)++instance Functor (Validated e) where+  fmap f (OK x)    = OK (f x)+  fmap _ (NotOK e) = NotOK e++instance Semigroup e => Applicative (Validated e) where+  pure x = OK x++  OK f    <*> OK x     = OK (f x)+  OK _    <*> NotOK e  = NotOK e+  NotOK e <*> OK _     = NotOK e+  NotOK e <*> NotOK e' = NotOK (e <> e')++instance Foldable (Validated e) where+  foldMap f (OK x)    = f x+  foldMap _ (NotOK _) = mempty++instance Traversable (Validated e) where+  traverse f (OK x)    = fmap OK (f x)+  traverse _ (NotOK x) = pure (NotOK x)++instance (Semigroup e, Semigroup a) => Semigroup (Validated e a) where+  NotOK e <> NotOK e' = NotOK (e <> e')+  NotOK e <> OK _     = NotOK e+  OK a    <> OK b     = OK (a <> b)+  OK _    <> NotOK e  = NotOK e++validateEither :: Either e a -> Validated e a+validateEither (Left e)  = NotOK e+validateEither (Right x) = OK x++eitherValidate :: Validated e a -> Either e a+eitherValidate (OK x)    = Right x+eitherValidate (NotOK e) = Left e++ok :: Applicative m => a -> ValidateT e m a+ok = VT . pure . OK++no :: Applicative m => e -> ValidateT e m a+no = VT . pure . NotOK++validated :: (e -> r) -> (a -> r) -> Validated e a -> r+validated f _ (NotOK e) = f e+validated _ f (OK x)    = f x++newtype ValidateT e m a = VT+  { runValidateT :: m (Validated e a) }++validate :: m (Validated e a) -> ValidateT e m a+validate = VT++instance Functor m => Functor (ValidateT e m) where+  fmap f (VT m) = VT $ fmap (fmap f) m++instance (Applicative m, Semigroup e) => Applicative (ValidateT e m) where+  pure = VT . pure . pure++  VT f <*> VT x = VT . getCompose $ Compose f <*> Compose x++instance (Applicative m, Semigroup e, Semigroup a) => Semigroup (ValidateT e m a) where+  VT a <> VT b = VT $ (<>) <$> a <*> b
− src/Servant/HTML/EDE.hs 
@@ -1,229 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module:      Servant.HTML.EDE--- Copyright:   (c) 2015 Alp Mestanogullari--- License:     BSD3--- Maintainer:  Alp Mestanogullari <alpmestan@gmail.com>--- Stability:   experimental------ Combinators for rendering <http://hackage.haskell.org/package/ede ede>--- templates in servant web applications.-module Servant.HTML.EDE (-    -- * Introduction-    -- $intro--    -- * Explicitly binding data to a template-    -- $explicit--    -- * Template rendering as a content-type-    -- $contenttype-    -    -- * Reference--    -- ** 'Tpl' combinator, for explicit data binding-    Tpl-  -  , -- ** 'HTML' content type, for serializing data types to HTML-    HTML-  , ToObject(..)--  , -- ** Loading templates-    loadTemplates-  , TemplateError-  , Errors--  , -- ** Helpers-    TemplateFiles-  , Reify(..)--  , -- * Global template store-    -- $templatestore-  ) where--import Control.Applicative-import Control.Concurrent.MVar-import Control.Monad.IO.Class-import Data.Aeson-import Data.Foldable-import Data.HashMap.Strict-import Data.Traversable-import Servant-import Servant.HTML.EDE.Internal---- | Same as 'loadTemplates', except that it initializes a global---   template store (i.e a 'Templates' value) and fills it with---   the resulting compiled templates if all of them are compiled---   successfully. If that's not the case, the global template store---   (under an 'MVar') is left empty.------   /IMPORTANT/: Must /always/ be called before starting your /servant/ application.-loadTemplates :: (Reify (TemplateFiles api), Applicative m, MonadIO m)-              => Proxy api-              -> FilePath -- ^ root directory for the templates-              -> m Errors-loadTemplates proxy dir = do-  res <- loadTemplates' proxy dir-  case res of-    Left errs  -> return errs-    Right tpls -> do-      liftIO $ putMVar __template_store tpls-      return []--loadTemplates' :: (Reify (TemplateFiles api), Applicative m, MonadIO m)-               => Proxy api-               -> FilePath   -- ^ root directory for the templates-               -> m (Either Errors Templates)-loadTemplates' proxy templatedir =-  fmap (eitherValidate . fmap fold) . runValidateT $-    traverse (processFile templatedir) files--  where files :: [FilePath]-        files = templateFiles proxy---- $intro------ The <http://hackage.haskell.org/package/ede ede> library provides--- a reasonably good template engine. This package explores--- a smooth integration of /ede/ into <http://haskell-servant.github.io/ servant>--- through two combinators.---- $explicit------ The first combinator is 'Tpl', which is used for generating web pages--- from /ede/ templates by explicitly returning an 'Object'--- (which is a synonym for @'HashMap' 'Text' 'Value'@, i.e a /JSON object/)--- from the handler which will then be rendered against a given template.------ @--- -- we want our template file, index.html,--- -- to be rendered under /index--- type API = "index" :> 'Tpl' "index.html"------ api :: 'Proxy' API--- api = Proxy------ server :: 'Server' API--- server = return indexData------   where indexData :: 'Object'---         indexData =---           HM.fromList [ ("company_name", "Foo Inc.")---                       , ("ceo", "Bar Baz")---                       ]------ main :: IO ()--- main = do---   -- this tells the library to look for index.html---   -- under the ./templates directory---   'loadTemplates' api "./templates"---   run 8080 server--- @------ Note that if your template doesn't need any data, you can just--- return the empty 'Object', with "Data.Monoid"\'s 'mempty'.------ The call to 'loadTemplates' is mandatory. It loads and compiles all the--- templates used in your API and puts them in a global \"compiled template store\".--- I'm not really satisfied with this, see the /Global template store/ section--- for more on this topic.---- $contenttype------ The other way to use this package is reminiscent of how you can render HTML--- with <http://hackage.haskell.org/package/servant-blaze servant-blaze> or--- its cousin <http://hackage.haskell.org/package/servant-lucid servant-lucid>.--- Indeed, this package provides an 'HTML' content type just like the two--- aforementionned libraries. However, unlike in these packages, this 'HTML'--- type is parametrised by a type-level string meant to be the name of the--- template file (or path to the template file starting from a \"root\" directory--- of templates).------ In the same way that /servant/'s standard 'JSON' combinator--- carries the precise way in which we encode haskell values to JSON,--- in addition to representing the @application/json@ content type,--- 'HTML' carries the template used to render values of a given type.------ If we wanted to have a @/user@ endpoint accessible in JSON or HTML,--- returning a user, we could write:------ @--- type UserAPI = "user" :> 'Get' '['JSON', 'HTML' "user.tpl"] User------ userAPI :: Proxy UserAPI--- userAPI = Proxy--- @------ How, then, can /servant/ know how to marshall @User@ to the template--- in order to render it? Simple, you just have to provide an instance of--- the following 'ToObject' class:------ @--- class ToObject a where---   toObject :: a -> 'Object'--- @------ If our @User@ data type is:------ > data User = User { name :: String, age :: Int }------ we can simply do, using functions from "Text.EDE":------ @--- instance ToObject User where---   toObject u =---     fromPairs [ "name" .= name u---               , "age"  .= age u---               ]--- @------ However, this is actually not necessary. This library provides can--- derive the 'ToObject' instance for you as long as your data type--- derives the "GHC.Generics.Generic" class, which can be done by specifying--- @{-# LANGUAGE DeriveGeneric #-}@ at the top of your module, adding--- @import GHC.Generics@ and by changing the @User@ data type declaration to:------ > data User = User { name :: String, age :: Int } deriving Generic------ You can then simply write:------ > instance ToObject User------ and the library will figure out how to encode @User@ to JSON for you.--- /IMPORTANT/: This only works with data types with a single record and--- field selectors.------ Now we can put this all to work with a simple webservice:------ @--- server :: Server UserAPI--- server = return (User "lambdabot" 31)------ main :: IO ()--- main = do---   loadTemplates userAPI "./templates"---   run 8082 (serve userAPI server)--- @------ Again, the call to 'loadTemplates' is mandatory because the 'HTML'--- content type relies on having its hands on already-compiled templates.------ You can now write a @user.tpl@ template under the @./templates@ directory--- using any of <http://hackage.haskell.org/package/ede ede>'s constructs,--- assuming that a @name@ string variable and an @age@ int variable are in scope.---- $templatestore------ Why have a global template store? Well, while for 'Tpl' we can run arbitrary code--- in the handlers, take arguments and what not, that's not the case when writing the--- 'MimeRender' instance for 'HTML'.------ All we have is a value of some type and we have to pull a compiled template out of--- thin air. That's why we use a global 'MVar'-protected template store indexed by filename.--- It's filled once at the beginning when you call 'loadTemplates' and is then only accessed--- in a /read-only/ fashion. I would be interested in hearing about any suggestion,--- improvement or replacement for this. If you have an idea, feel free to shoot me an--- email at the address specified in the cabal description.
− src/Servant/HTML/EDE/Internal.hs 
@@ -1,12 +0,0 @@-module Servant.HTML.EDE.Internal-  ( module Servant.HTML.EDE.Internal.Reify-  , module Servant.HTML.EDE.Internal.Templates-  , module Servant.HTML.EDE.Internal.ToObject-  , module Servant.HTML.EDE.Internal.Validate-  ) where--import Servant.HTML.EDE.Internal.Reify-import Servant.HTML.EDE.Internal.Templates-import Servant.HTML.EDE.Internal.ToObject-import Servant.HTML.EDE.Internal.Validate-
− src/Servant/HTML/EDE/Internal/Reify.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Servant.HTML.EDE.Internal.Reify (Reify(..)) where--import Data.Proxy-import GHC.TypeLits---- | Helper class to reify a type-level list of strings---   into a value-level list of string. Used to turn---   the type-level list of template file names into---   a value-level list.-class Reify (symbols :: [Symbol]) where-  reify :: Proxy symbols -> [String]--instance Reify '[] where-  reify _ = []--instance (KnownSymbol s, Reify symbols)-      => Reify (s ': symbols) where-  reify _ = symbolVal ps : reify psymbols--    where ps = Proxy :: Proxy s-          psymbols = Proxy :: Proxy symbols
− src/Servant/HTML/EDE/Internal/Templates.hs 
@@ -1,224 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Servant.HTML.EDE.Internal.Templates-  ( Tpl-  , HTML-  , Templates(..)-  , templateMap-  , __template_store-  , TemplateFiles-  , TemplateError-  , Errors-  , processFile-  , templateFiles-  ) where--import Control.Concurrent.MVar-import Control.Monad.IO.Class-import Control.Monad.Trans.Either-import Data.Aeson (Object)-import Data.ByteString.Lazy.Char8 (pack)-import Data.HashMap.Strict-import Data.Proxy-import Data.Semigroup-import Data.Text.Lazy.Encoding (encodeUtf8)-import GHC.TypeLits-import Network.HTTP.Media hiding (Accept)-import Network.HTTP.Types-import Network.Wai-import Servant-import Servant.HTML.EDE.Internal.Reify-import Servant.HTML.EDE.Internal.ToObject-import Servant.HTML.EDE.Internal.Validate-import Servant.Server.Internal-import Servant.Server.Internal.ServantErr-import System.FilePath-import System.IO.Unsafe (unsafePerformIO)-import Text.EDE--import qualified Data.HashMap.Strict as HM--__template_store :: MVar Templates-__template_store = unsafePerformIO newEmptyMVar---- | Combinator for serving EDE templates without arguments. Usage:------ > type API = "index" :> Tpl "index.tpl"--- >       :<|> "about" :> Tpl "about.tpl"--- >--- > api :: Proxy API--- > api = Proxy--- >--- > server :: Templates -> Server API--- > server tpls = return mempty :<|> return mempty--- >--- > main :: IO ()--- > main = do--- >   loadTemplates_ api "./templates"--- >   run 8080 (serve api server)-data Tpl (tplfile :: Symbol)----- | The so-called "request handler" for an endpoint ending---   with 'Tpl' just has to be the opaque 'Templates' value---   returned by 'Servant.HTML.EDE.loadTemplates' applied to your API, which---   is just a compiled template store indexed by file name.-instance KnownSymbol tplfile => HasServer (Tpl tplfile) where-  type ServerT (Tpl tplfile) m = m Object--  route Proxy mobj request respond-    | pathIsEmpty request && requestMethod request == methodGet = do-        tpls <- getTemplates-        val <- runEitherT mobj-        case val of-          Left e -> respond . succeedWith $ responseServantErr e-          Right v  -> -            case mbody tpls v of-              Success body -> respond . succeedWith $-                responseLBS ok200 [("Content-Type", "text/html")] (encodeUtf8 body)-              Failure doc  -> respond . succeedWith $-                responseLBS status500 [] ("template error: " <> pack (show doc))--    | pathIsEmpty request && requestMethod request /= methodGet =-        respond (failWith WrongMethod)--    | otherwise = respond (failWith NotFound)--    where filename = symbolVal (Proxy :: Proxy tplfile)-          mbody ts val = render (ts HM.! filename) val-          getTemplates = fmap templateMap (readMVar __template_store)---- | 'HTML' content type, but more than just that.------   'HTML' takes a type-level string which is---   a filename for the template you want to use to---   render values. Example:------ @--- type UserAPI = "user" :> Get '[JSON, HTML "user.tpl"] User------ userAPI :: Proxy UserAPI--- userAPI = Proxy------ data User = User { name :: String, age :: Int } deriving Generic------ instance ToJSON User--- instance ToObject User------ server :: Server API--- server = return (User "lambdabot" 31)------ main :: IO ()--- main = do---   loadTemplates userAPI "./templates"---   run 8082 (serve userAPI server)--- @------ This will look for a template at @.\/templates\/user.tpl@, which could--- for example be:------ > <ul>--- >   <li><strong>Name:</strong> {{ name }}</li>--- >   <li><strong>Age:</strong> {{ age }}</li>--- > </ul>-data HTML (tplfile :: Symbol)---- | @text\/html;charset=utf-8@-instance Accept (HTML tplfile) where-  contentType _ = "text" // "html" /: ("charset", "utf-8")--instance (KnownSymbol tplfile, ToObject a)-      => MimeRender (HTML tplfile) a where-  mimeRender _ val = encodeUtf8 . result (error . show) id $-    render templ (toObject val)--    where templ = tmap ! filename-          filename = symbolVal (Proxy :: Proxy tplfile)-          tmap = templateMap $ unsafePerformIO (readMVar __template_store)--type family Append (xs :: [k]) (ys :: [k]) :: [k] where-  Append '[]       ys = ys-  Append (x ': xs) ys = x ': Append xs ys--type family Member (x :: k) (xs :: [k]) :: Bool where-  Member x (x ': xs) = 'True-  Member x (y ': xs) = Member x xs-  Member x       '[] = False---- | Collect all the template filenames of an API as a type-level---   list of strings, by simply looking at all occurences of the---   'Tpl' and 'HTML' combinators and keeping the filenames associated to them.-type family TemplateFiles (api :: k) :: [Symbol]-type instance TemplateFiles (a :<|> b)    = Append (TemplateFiles a) (TemplateFiles b)-type instance TemplateFiles (a :> r)      = TemplateFiles r-type instance TemplateFiles (Tpl f)       = '[f]-type instance TemplateFiles (Delete cs a) = CTFiles cs-type instance TemplateFiles (Get cs a)    = CTFiles cs-type instance TemplateFiles (Patch cs a)  = CTFiles cs-type instance TemplateFiles (Post cs a)   = CTFiles cs-type instance TemplateFiles (Put cs a)    = CTFiles cs-type instance TemplateFiles Raw           = '[]--type family CTFiles (cts :: [*]) :: [Symbol] where-  CTFiles '[]        = '[]-  CTFiles (c ': cts) = Append (CTFile c) (CTFiles cts)--type family CTFile c :: [Symbol] where-  CTFile (HTML fp) = '[fp]-  CTFile         a = '[]--templates :: Proxy api -> Proxy (TemplateFiles api)-templates Proxy = Proxy--templateFiles :: Reify (TemplateFiles api) => Proxy api -> [FilePath]-templateFiles = reify . templates---- | An opaque "compiled-template store".------ The only way to get a value of this type is to use--- 'Servant.EDE.loadTemplates' on a proxy of your API.------ This ensures that when we lookup a template (in order--- to render it) in our 'Templates' store, we are--- guaranteed to find it.-newtype Templates = Templates (HashMap String Template)-  deriving Eq--templateMap :: Templates -> HashMap String Template-templateMap (Templates m) = m--instance Semigroup Templates where-  Templates a <> Templates b = Templates (a <> b)--instance Monoid Templates where-  mempty = Templates mempty--  a `mappend` b = a <> b--tpl :: FilePath -> Template -> Templates-tpl fp t = Templates $ HM.singleton fp t---- | A 'TemplateError' is a pair of a template filename---   and the error string for that file.-type TemplateError = (FilePath, String)---- | A list of 'TemplateError's.-type Errors = [TemplateError]--err :: Show a => FilePath -> a -> Errors-err fp d = [(fp, show d)]--processFile :: MonadIO m => FilePath -> FilePath -> ValidateT Errors m Templates-processFile d fp = validate . liftIO $ parseFile' (d </> fp)--  where parseFile' f = fmap validateResult (parseFile f)-        validateResult (Success t) = OK (tpl fp t)-        validateResult (Failure e) = NotOK (err fp e)
− src/Servant/HTML/EDE/Internal/ToObject.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}--- {-# LANGUAGE OverloadedStrings #-}-module Servant.HTML.EDE.Internal.ToObject where--import Data.Aeson-import Data.HashMap.Strict-import Data.Monoid-import Data.Text-import GHC.Generics---- | Turn haskell values into JSON objects.------ This is the mechanism used by EDE to marshall data from Haskell--- to the templates. The rendering is then just about feeding the--- resulting 'Object' to a compiled 'Template'. Example:------ > import Text.EDE--- >--- > data User = User { name :: String, age :: Int }--- > instance ToObject User where--- >   toObject user =--- >     fromPairs [ "name" .= name user--- >               , "age"  .= age user--- >               ]------ However, you're not forced to write the instance yourself for such a type.--- Indeed, for any record type (i.e a datatype with a single constructor and--- with field selectors) you can let @GHC.Generics@ derive the 'ToObject' instance--- for you.------ > data User = User { name :: String, age :: Int } deriving Generic--- > instance ToObject User------ This will generate an equivalent instance to the previous one.-class ToObject a where--  -- | Turn values of type @a@ into JSON 'Object's.-  ---  -- @ -  -- -- Reminder:-  -- type Object = 'HashMap' 'Text' 'Value'-  -- @-  toObject :: a -> Object-  -  default toObject :: (Generic a, GToObject (Rep a)) => a -> Object-  toObject = genericToObject--instance ToObject (HashMap Text Value) where-  toObject = id--class GToObject f where-  gtoObject :: f a -> Object--instance GToObject V1 where-  gtoObject _ = mempty--instance GToObject U1 where-  gtoObject U1 = mempty--instance (GToObject f, GToObject g)-      => GToObject (f :*: g) where-  gtoObject (f :*: g) = gtoObject f <> gtoObject g--instance GToObject a => GToObject (M1 D d a) where-  gtoObject (M1 x) = gtoObject x--instance GToObject a => GToObject (M1 C c a) where-  gtoObject (M1 x) = gtoObject x--instance (Selector s, ToJSON a) => GToObject (M1 S s (K1 r a)) where-  gtoObject s@(M1 (K1 x)) = fromList [(fieldname, value)]-    where fieldname = pack (selName s)-          value     = toJSON x--genericToObject :: (Generic a, GToObject (Rep a)) => a -> Object-genericToObject = gtoObject . from------------------
− src/Servant/HTML/EDE/Internal/Validate.hs 
@@ -1,71 +0,0 @@-module Servant.HTML.EDE.Internal.Validate where--import Control.Applicative-import Data.Foldable-import Data.Traversable-import Data.Functor.Compose-import Data.Semigroup--data Validated e a = OK a | NotOK e-  deriving (Eq, Show)--instance Functor (Validated e) where-  fmap f (OK x)    = OK (f x)-  fmap _ (NotOK e) = NotOK e--instance Semigroup e => Applicative (Validated e) where-  pure x = OK x--  OK f    <*> OK x     = OK (f x)-  OK _    <*> NotOK e  = NotOK e-  NotOK e <*> OK _     = NotOK e-  NotOK e <*> NotOK e' = NotOK (e <> e')--instance Foldable (Validated e) where-  foldMap f (OK x)    = f x-  foldMap _ (NotOK _) = mempty--instance Traversable (Validated e) where-  traverse f (OK x)    = fmap OK (f x)-  traverse _ (NotOK x) = pure (NotOK x)--instance (Semigroup e, Semigroup a) => Semigroup (Validated e a) where-  NotOK e <> NotOK e' = NotOK (e <> e')-  NotOK e <> OK _     = NotOK e-  OK a    <> OK b     = OK (a <> b)-  OK _    <> NotOK e  = NotOK e--validateEither :: Either e a -> Validated e a-validateEither (Left e)  = NotOK e-validateEither (Right x) = OK x--eitherValidate :: Validated e a -> Either e a-eitherValidate (OK x)    = Right x-eitherValidate (NotOK e) = Left e--ok :: Applicative m => a -> ValidateT e m a-ok = VT . pure . OK--no :: Applicative m => e -> ValidateT e m a-no = VT . pure . NotOK--validated :: (e -> r) -> (a -> r) -> Validated e a -> r-validated f _ (NotOK e) = f e-validated _ f (OK x)    = f x--newtype ValidateT e m a = VT-  { runValidateT :: m (Validated e a) }--validate :: m (Validated e a) -> ValidateT e m a-validate = VT--instance Functor m => Functor (ValidateT e m) where-  fmap f (VT m) = VT $ fmap (fmap f) m--instance (Applicative m, Semigroup e) => Applicative (ValidateT e m) where-  pure = VT . pure . pure--  VT f <*> VT x = VT . getCompose $ Compose f <*> Compose x--instance (Applicative m, Semigroup e, Semigroup a) => Semigroup (ValidateT e m a) where-  VT a <> VT b = VT $ (<>) <$> a <*> b