diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ # servant-ede 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). + diff --git a/example/example.hs b/example/example.hs --- a/example/example.hs +++ b/example/example.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + import Control.Monad -import Data.Monoid import GHC.Generics import Network.HTTP.Media ((//)) import Network.Wai.Handler.Warp import Servant import Servant.EDE import Text.EDE.Filters ((@:),Term) -import qualified Data.HashMap.Strict as Map import Data.Text (Text, chunksOf) -- * Using 'Tpl' for rendering CSS templates @@ -20,8 +20,11 @@ instance Accept CSS where contentType _ = "text" // "css" -type StyleAPI = "style.css" :> Get '[Tpl CSS "style.tpl"] CSSData +type StyleAPI = "style.css" :> Get '[Tpl CSS] CSSData +instance HasTemplate CSS CSSData where + templateFor _ _ = "style.tpl" + data CSSData = CSSData { darken :: Bool , pageWidth :: Int @@ -40,8 +43,11 @@ instance ToObject User where -type UserAPI = "user" :> Get '[HTML "user.tpl"] User +instance HasTemplate HTML User where + templateFor _ _ = "user.tpl" +type UserAPI = "user" :> Get '[HTML] User + userServer :: Server UserAPI userServer = return (User "lambdabot" 35) @@ -55,8 +61,10 @@ main :: IO () main = do - loadTemplates api filters "example" - run 8082 (serve api $ styleServer :<|> userServer) + void $ do + app <- serveWithContextAndTemplates filters "example" () api EmptyContext $ styleServer :<|> userServer + run 8082 app + -- You can now head to: -- http://localhost:8082/user diff --git a/example/test-example.hs b/example/test-example.hs new file mode 100644 --- /dev/null +++ b/example/test-example.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +import Control.Monad +import Data.Bifunctor (first) +import Data.Either (isRight) +import Data.Foldable +import Data.HashMap.Strict (HashMap, fromList) +import Data.Map (Map) +import Data.Proxy (Proxy(..), asProxyTypeOf) +import Data.Text (Text, chunksOf) +import GHC.Generics +import Network.HTTP.Media ((//)) +import Servant.API +import Servant.EDE +import System.FilePath (()) +import Test.Hspec +import Test.QuickCheck +import Text.EDE (parseFile, renderWith, eitherResult) +import Text.EDE.Filters ((@:),Term) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap + +-- * Using 'Tpl' for rendering CSS templates + +data CSS + +instance Accept CSS where + contentType _ = "text" // "css" + +type StyleAPI = "style.css" :> Get '[Tpl CSS] CSSData + +instance HasTemplate CSS CSSData where + templateFor _ _ = "style.tpl" + +data CSSData = CSSData + { darken :: Bool + , pageWidth :: Int + } deriving (Show, Generic) + +instance ToObject CSSData + +instance Arbitrary CSSData where + arbitrary = CSSData <$> arbitrary <*> arbitrary + +-- * Using 'HTML' for HTML template rendering + +data User = User { name :: String, age :: Int } + deriving (Eq, Show, Generic) + +instance ToObject User where + +instance Arbitrary User where + arbitrary = User <$> arbitrary <*> arbitrary + +instance HasTemplate HTML User where + templateFor _ _ = "user.tpl" + +type UserAPI = "user" :> Get '[HTML] User + +-- * Define an API +type API = StyleAPI :<|> UserAPI + +api :: Proxy API +api = Proxy + + +-- * Define a constraint synonym so 'ReifiedTemplate' can guarantee every +-- template is testable. + +class (Arbitrary a, Show a) => TemplateTestable a +instance (Arbitrary a, Show a) => TemplateTestable a + +templates :: Map FilePath (ReifiedTemplate TemplateTestable ()) +templates = reifyTemplates api + + +-- * Iterate over the templates, generating a property test showing that the +-- template compiles and that it can be instantiated with arbitrary data. + +main :: IO () +main = hspec $ do + for_ templates $ \(ReifiedTemplate pa path _) -> + beforeAll (either error pure . eitherResult =<< parseFile ("example" path)) $ do + it (unwords [path, "compiles"]) $ \template -> + -- If the templated compiled, we can try rendering it with synthetic data. + -- The goal is to see if we can find any inputs which cause it to fail to + -- render. + property $ forAll arbitrary $ \a -> + eitherResult (renderWith filters template $ toEdeObject (a `asProxyTypeOf` pa)) + `shouldSatisfy` isRight + +filters :: HashMap Text Term +filters = ["toChars" @: (chunksOf 1)] + diff --git a/servant-ede.cabal b/servant-ede.cabal --- a/servant-ede.cabal +++ b/servant-ede.cabal @@ -1,5 +1,5 @@ name: servant-ede -version: 0.6 +version: 1.0.0.0 synopsis: Combinators for rendering EDE templates in servant web applications description: Combinators for rendering EDE templates in servant web applications. @@ -10,40 +10,42 @@ license: BSD3 license-file: LICENSE author: Alp Mestanogullari -maintainer: alpmestan@gmail.com -copyright: 2015-2016 Alp Mestanogullari +maintainer: sandy.maguire@tweag.io +copyright: 2015-2026 Alp Mestanogullari category: Web build-type: Simple extra-source-files: README.md -cabal-version: >=1.10 +cabal-version: 2.0 source-repository head type: git - location: git://github.com/alpmestan/servant-ede.git + location: https://github.com/alpmestan/servant-ede.git library exposed-modules: Servant.EDE , Servant.EDE.Internal - , Servant.EDE.Internal.Reify , Servant.EDE.Internal.ToObject , Servant.EDE.Internal.Validate build-depends: - aeson + aeson ^>= 2.2.3.0 , base >=4.7 && <5 - , bytestring - , filepath - , ede - , either - , http-media - , http-types - , semigroups - , servant - , text - , transformers - , unordered-containers - , vector - , xss-sanitize + , bytestring >= 0.10.4 && < 0.13 + , filepath >= 1.2 && < 1.6 + , ede ^>= 0.3.4.0 + , either ^>= 5.0.3 + , http-media ^>= 0.8.1.1 + , http-types ^>= 0.12.4 + , semigroups ^>= 0.20.1 + , containers ^>= 0.7 + , monoidal-containers ^>= 0.6.7.0 + , servant >= 0.18 && < 0.21 + , servant-server >= 0.18 && < 0.21 + , text ^>= 2.1.3 + , transformers ^>= 0.6.1.1 + , unordered-containers >= 0.2.3 && < 0.3 + , vector >= 0.7.1 && < 0.14 + , xss-sanitize ^>= 0.3.7.2 ghc-options: -Wall hs-source-dirs: src @@ -62,4 +64,23 @@ , servant-ede , text , unordered-containers - , warp + , warp >=3.2.25 && <3.5 + + +executable template-test-example + main-is: test-example.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: + base + , ede + , http-media + , servant + , servant-ede + , text + , unordered-containers + , containers + , QuickCheck >= 2.13.2 && < 2.19 + , hspec >= 2.6 && < 2.12 + , aeson + , filepath diff --git a/src/Servant/EDE.hs b/src/Servant/EDE.hs --- a/src/Servant/EDE.hs +++ b/src/Servant/EDE.hs @@ -1,30 +1,46 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 900 +{-# LANGUAGE AllowAmbiguousTypes #-} +#endif +#if __GLASGOW_HASKELL__ < 904 +{-# LANGUAGE ConstraintKinds #-} +#endif +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Servant.EDE -- Copyright : (c) Alp Mestanogullari 2015 --- Maintainer : alpmestan@gmail.com --- Stability : experimental +-- Maintainer : sandy.maguire@tweag.io +-- Stability : stable -- -- 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. +-- - 'HTML' 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. @@ -36,99 +52,177 @@ -- * Sending Haskell data to templates , ToObject(..) + , toEdeObject - , -- * Loading template files (mandatory) - loadTemplates - , TemplateFiles - , Reify - , Templates - , Errors - , TemplateError + , serveWithContextAndTemplates + , unsafeLoadTemplates + , LoadedTemplates + , TemplateFiles(..) + , ReifiedTemplate(..) + , instantiate + , Trivial + , ContentTemplateFiles(..) + , HasTemplate(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative -import Data.Traversable (traverse) #endif -import Control.Concurrent import Control.Monad.IO.Class +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Map.Monoidal as MM +import Data.Map.Monoidal (MonoidalMap) +import qualified Data.Set as S +import Data.Set (Set) +import Data.Traversable (for) +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Base (withDict) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Key as Key import Data.Aeson (Object, Value(..)) +import Data.Bifunctor (first) import Data.Foldable (fold) +import Data.Kind import Data.HashMap.Strict (HashMap, (!),fromList) 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.EDE.Filters (Term) import Text.HTML.SanitizeXSS +import Data.ByteString.Lazy (ByteString) +import Servant.Server import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V +-- | Special class for safely passing IO-loaded templates into type-level +-- combinators. Instances of 'LoadedTemplates' are only provided by +-- 'serveWithContextAndTemplates' and 'unsafeLoadTemplates'. +-- +-- @since 1.0.0.0 +class LoadedTemplates where + loadedTemplates :: TemplatesAndFilters Trivial + +#if __GLASGOW_HASKELL__ < 904 +-- | Compatibility shim for @withDict@, which was only introduced in GHC 9.4. +-- +-- This implements the standard single-method-class reflection trick: a class +-- with a single method and no superclasses is represented at runtime exactly by +-- that method's value, so we can reinterpret the method as the class dictionary. +-- This is safe for 'LoadedTemplates', whose sole method is 'loadedTemplates'. +newtype Gift c r = Gift (c => r) + +withDict :: forall c meth r. meth -> (c => r) -> r +withDict meth k = unsafeCoerce (Gift k :: Gift c r) meth +#endif + +-- @since 0.6 type Filter = (Text,Term) --- | 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. + +-- @since 1.0.0.0 +serveWithContextAndTemplates + :: forall api ctx global + . ( LoadedTemplates => HasServer api ctx + , ServerContext ctx + , TemplateFiles Trivial api + , ToObject global + ) + => [Filter] + -> FilePath + -> global + -- ^ A global object that is available inside every templates. If the names + -- in this object overlap names in the template-specific object, the + -- template's keys will shadow the global object's. + -> Proxy api + -> Context ctx + -> ServerT api Handler + -> IO (Application) +serveWithContextAndTemplates fs dir global api ctx server = do + r <- + unsafeLoadTemplates (Proxy @api) fs dir global + $ pure + $ serveWithContext api ctx server + case r of + Left es -> + error $ unlines $ do + (fp, errs) <- M.toList es + (fp <> ":") : do + err <- S.toList errs + pure $ "- " <> err + Right a -> pure a + + +-- | 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, this function returns the +-- errors. -- --- /IMPORTANT/: Must /always/ be called before starting your /servant/ application. Example: +-- Example: -- --- > type API = Get '[HTML "home.tpl"] HomeData +-- > instance HasTemplate HTML HomeData where +-- > templateFor _ _ = "home.tpl" -- > +-- > type API = Get '[HTML] HomeData +-- > -- > api :: Proxy API -- > api = Proxy -- > -- > main :: IO () --- > main = loadTemplates api "path/to/templates" >>= print +-- > main = either print pure $ unsafeLoadTemplates api "path/to/templates" $ ... -- --- 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 - -> [Filter] -- ^ list of (Text,Term) pairs. Pass [] to use just the standard library - -> FilePath -- ^ root directory for the templates - -> m Errors -loadTemplates proxy fpairs dir = do +-- This would try to load @home.tpl@, printing any errors or performing the +-- actions given by @...@. +-- +-- This function is unsafe because nothing ties the provided 'LoadedTemplates' +-- instance to the given @api@. You should prefer +-- 'serveWithContextAndTemplates' whenever possible. +-- +-- @since 1.0.0.0 +unsafeLoadTemplates + :: (TemplateFiles Trivial api, MonadIO m, ToObject global) + => Proxy api + -> [Filter] -- ^ list of (Text,Term) pairs. Pass [] to use just the standard library + -> FilePath -- ^ root directory for the templates + -> global + -> (LoadedTemplates => m r) + -> m (Either (Map FilePath (Set String)) r) +unsafeLoadTemplates proxy fpairs dir global k = do let flts = fromList fpairs - res <- loadTemplates' proxy dir + res <- liftIO $ loadTemplates' @Trivial proxy dir case res of - Left errs -> return errs + Left errs -> pure $ Left $ MM.getMonoidalMap errs Right tpls -> do - let tplfs = TemplatesAndFilters tpls flts - liftIO $ putMVar __template_store tplfs - return [] + fmap Right $ withDict @LoadedTemplates (TemplatesAndFilters tpls flts $ toObject global) k -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 +loadTemplates' + :: forall c api + . (TemplateFiles c api, c ()) + => Proxy api + -> FilePath + -> IO (Either Errors (HashMap FilePath (ReifiedTemplate c Template))) +loadTemplates' proxy + = fmap (eitherValidate . fmap fold) + . runValidateT + . for (M.elems $ reifyTemplates proxy) + . processFile -- | 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'. +-- The parameter is the content-type you want to send along with rendered +-- templates (must be an instance of 'Accept'). -- -- Any type used with this content-type (like @CSSData@ below) -- must have an instance of the 'ToObject' class. The field names @@ -144,7 +238,7 @@ -- instance Accept CSS where -- contentType _ = "text" // "css" -- --- type StyleAPI = "style.css" :> Get '[Tpl CSS "style.tpl"] CSSData +-- type StyleAPI = "style.css" :> Get '[Tpl CSS] CSSData -- -- styleAPI :: Proxy StyleAPI -- styleAPI = Proxy @@ -154,6 +248,9 @@ -- , pageWidth :: Int -- } deriving Generic -- +-- instance HasTEmplate CSSData where +-- templateFor _ _ = "style.tpl" +-- -- instance ToObject CSSData -- -- server :: Server API @@ -161,8 +258,7 @@ -- -- main :: IO () -- main = do --- loadTemplates styleAPI "./templates" --- run 8082 (serve styleAPI server) +-- run 8082 =<< 'serveWithContextAndTemplates' [] "./templates" styleAPI EmptyContext server -- @ -- -- This will look for a template at @.\/templates\/style.tpl@, @@ -185,41 +281,59 @@ -- -- A complete, runnable version of this can be found -- in the @examples@ folder of the git repository. -data Tpl (ct :: *) (file :: Symbol) +-- +-- @since 0.4 +data Tpl (contentType :: Type) --- 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 Accept contentType => Accept (Tpl contentType) where + contentType _ = contentType $ Proxy @contentType -instance (KnownSymbol file, Accept ct, ToObject a) => MimeRender (Tpl ct file) a where - mimeRender _ val = encodeUtf8 . result (error . show) id $ - renderWith flts templ (toObject val) +-- | Given a content type and an type of handler output, give a path to an EDE +-- template file. +-- +-- @since 1.0.0.0 +class HasTemplate contentType a where + templateFor :: Proxy contentType -> Proxy a -> FilePath - where templ = tmap ! filename - filename = symbolVal (Proxy :: Proxy file) - tmplfs = unsafePerformIO (readMVar __template_store) - tmap = templateMap $ _templates tmplfs - flts = _filters tmplfs +-- | Common implementation of 'mimeRender'. +doMimeRender + :: (LoadedTemplates, ToObject a) + => (Object -> Object) + -- ^ Transformation on the object data before rendering. + -> FilePath + -> a + -> ByteString +doMimeRender process fp + = encodeUtf8 + . result (error . show) id + . renderWith (filters loadedTemplates) (unReifiedTemplate $ templates loadedTemplates ! fp) + . HM.fromList + . fmap (first Key.toText) + . KeyMap.toList + . process + . -- The object semigroup instance is left-biased, so we want to insert the + -- global object on the right to prevent any global shadowing. + (<> globalObj loadedTemplates) + . toObject -__template_store :: MVar TemplatesAndFilters -__template_store = unsafePerformIO newEmptyMVar +instance (LoadedTemplates, HasTemplate contentType a, Accept contentType, ToObject a) => MimeRender (Tpl contentType) a where + mimeRender _ = doMimeRender id $ templateFor (Proxy @contentType) (Proxy @a) -- | '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. +-- Just like 'Tpl', types used with the 'HTML' content type (like @User@ +-- below) must provide 'ToObject' and 'HasTemplate' instances. Unlike 'Tpl', +-- this type performs automatic escaping of HTML values to prevent XSS. -- -- Example: -- -- @ --- type UserAPI = "user" :> Get '[JSON, HTML "user.tpl"] User +-- type UserAPI = "user" :> Get '[JSON, HTML] User -- +-- instance HasTemplate HTML User where +-- templateFor _ _ = "user.tpl" +-- -- userAPI :: Proxy UserAPI -- userAPI = Proxy -- @@ -231,9 +345,7 @@ -- server = return (User "lambdabot" 31) -- -- main :: IO () --- main = do --- loadTemplates userAPI "./templates" --- run 8082 (serve userAPI server) +-- main = run 8082 =<< 'serveWithContextAndTemplates' [] "./templates" () userAPI NoContext server -- @ -- -- This will look for a template at @.\/templates\/user.tpl@, which could @@ -246,22 +358,23 @@ -- -- /IMPORTANT/: it XSS-sanitizes every bit of text in the 'Object' -- passed to the template. -data HTML (file :: Symbol) +-- +-- @since 0.4 +data HTML -- | @text/html;charset=utf-8@ -instance Accept (HTML file) where +instance Accept HTML 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) +instance (LoadedTemplates, HasTemplate HTML a, ToObject a) => MimeRender HTML a where + mimeRender _ = doMimeRender sanitizeObject $ templateFor (Proxy @HTML) (Proxy @a) sanitizeObject :: Object -> Object -sanitizeObject = HM.fromList . map sanitizeKV . HM.toList +sanitizeObject = KeyMap.fromList . map sanitizeKV . KeyMap.toList -sanitizeKV :: (Text, Value) -> (Text, Value) -sanitizeKV (k, v) = (sanitize k, sanitizeValue v) +sanitizeKV :: (Key.Key, Value) -> (Key.Key, Value) +sanitizeKV (k, v) = (Key.fromText . sanitize $ Key.toText k, sanitizeValue v) sanitizeValue :: Value -> Value sanitizeValue (String s) = String (sanitize s) @@ -269,88 +382,152 @@ 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 +-- | Collect all the template filenames of an API by simply looking at all +-- occurences of the 'Tpl' and 'HTML' combinators and keeping the filenames +-- associated to them. +-- +-- The @c@ parameter is of kind @'Type' -> 'Constraint'@ and can be used to +-- ensure every that every return type in your API satisfies some constraint. +-- If you don't have a need for this parameter, you can fill it in with +-- 'Trivial'. +-- +-- @since 1.0.0.0 +type TemplateFiles :: (Type -> Constraint) -> k -> Constraint +class TemplateFiles c api where + reifyTemplates :: Proxy api -> Map FilePath (ReifiedTemplate c ()) -type family Member (x :: k) (xs :: [k]) :: Bool where - Member x (x ': xs) = 'True - Member x (y ': xs) = Member x xs - Member x '[] = 'False +instance (TemplateFiles c a, TemplateFiles c b) => TemplateFiles c (a :<|> b) where + reifyTemplates _ = reifyTemplates (Proxy @a) <> reifyTemplates (Proxy @b) --- | 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 = '[] +instance (TemplateFiles c api) => TemplateFiles c (a :> api) where + reifyTemplates _ = reifyTemplates $ Proxy @api -type family CTFiles (cts :: [*]) :: [Symbol] where - CTFiles '[] = '[] - CTFiles (c ': cts) = Append (CTFile c) (CTFiles cts) +instance ContentTemplateFiles c contentType a => TemplateFiles c (Verb m s contentType a) where + reifyTemplates _ = contentTemplatesFor (Proxy @contentType) (Proxy @a) -type family CTFile c :: [Symbol] where - CTFile (HTML fp) = '[fp] - CTFile (Tpl ct fp) = '[fp] - CTFile a = '[] +instance TemplateFiles c Raw where + reifyTemplates _ = mempty -templates :: Proxy api -> Proxy (TemplateFiles api) -templates Proxy = Proxy +instance TemplateFiles c (ToServantApi a) => TemplateFiles c (NamedRoutes a) where + reifyTemplates _ = reifyTemplates (Proxy @(ToServantApi a)) -templateFiles :: Reify (TemplateFiles api) => Proxy api -> [FilePath] -templateFiles = reify . templates +instance TemplateFiles c EmptyAPI where + reifyTemplates _ = mempty --- | 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. + +-- | Collect template files for a given set of content types. -- --- 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 +-- @since 1.0.0.0 +type ContentTemplateFiles :: (Type -> Constraint) -> [Type] -> Type -> Constraint +class ContentTemplateFiles c contentType a where + contentTemplatesFor :: Proxy contentType -> Proxy a -> Map FilePath (ReifiedTemplate c ()) -templateMap :: Templates -> HashMap String Template -templateMap (Templates m) = m +instance ContentTemplateFiles c '[] a where + contentTemplatesFor _ _ = mempty -instance Semigroup Templates where - Templates a <> Templates b = Templates (a <> b) +instance + {-# OVERLAPPING #-} + ( HasTemplate HTML a + , ContentTemplateFiles c contentTypes a + , ToObject a + , c a + ) + => ContentTemplateFiles c (HTML ': contentTypes) a where + contentTemplatesFor _ pa = + let fp = templateFor (Proxy @HTML) pa + in M.insert fp (ReifiedTemplate (Proxy @a) fp ()) $ contentTemplatesFor (Proxy @contentTypes) pa -instance Monoid Templates where - mempty = Templates mempty +instance + {-# OVERLAPPING #-} + ( HasTemplate contentType a + , ContentTemplateFiles c contentTypes a + , ToObject a + , c a + ) + => ContentTemplateFiles c (Tpl contentType ': contentTypes) a where + contentTemplatesFor _ pa = + let fp = templateFor (Proxy @contentType) pa + in M.insert fp (ReifiedTemplate (Proxy @a) fp ()) $ contentTemplatesFor (Proxy @contentTypes) pa - a `mappend` b = a <> b +instance + {-# OVERLAPPABLE #-} + (ContentTemplateFiles c contentTypes a) + => ContentTemplateFiles c (contentType ': contentTypes) a where + contentTemplatesFor _ pa = contentTemplatesFor (Proxy @contentTypes) pa -- A data type that holds both the compiled templates and -- any passed-in custom filters -data TemplatesAndFilters = TemplatesAndFilters { - _templates :: Templates - , _filters :: HashMap Text Term - } +data TemplatesAndFilters c = TemplatesAndFilters + { templates :: HashMap FilePath (ReifiedTemplate c Template) + , filters :: HashMap Text Term + , globalObj :: Object + } -tpl :: FilePath -> Template -> Templates -tpl fp t = Templates $ HM.singleton fp t +-- | A trivial class that always has instances for every type. This is useful +-- when you don't need the full power of 'TemplateFiles' or 'ReifiedTemplate'. +class Trivial a +instance Trivial a --- | A 'TemplateError' is a pair of a template filename --- and the error string for that file. -type TemplateError = (FilePath, String) +-- | A 'ReifiedTemplate' contains the filepath of the template, as well as its +-- return type, and an optional constraint @c@ that the return type is +-- guaranteed to satisfy. For example, you can generate property tests showing +-- that your templates compile and can be instantiated by letting @c +-- ~ TestableC@, where +-- +-- @ +-- class (Show a, Eq a, Arbitrary a) => TestableC a +-- instance (Show a, Eq a, Arbitrary a) => TestableC a +-- @ +-- +-- and then use 'reifyTemplates' to get a map of @'ReifiedTemplate' TestableC ()@s. +-- By subsequently pattern matching on the 'ReifiedTemplate' constructor, you +-- now have everything in scope necessary to write a quickcheck-style property +-- test. +type ReifiedTemplate :: (Type -> Constraint) -> Type -> Type +data ReifiedTemplate c x where + ReifiedTemplate + :: (c a, ToObject a) + => { mt_proxy :: Proxy a + , mt_path :: FilePath + , unReifiedTemplate :: x + } -> ReifiedTemplate c x --- | A list of 'TemplateError's. -type Errors = [TemplateError] +instance Functor (ReifiedTemplate c) where + fmap f (ReifiedTemplate p fp a) = ReifiedTemplate p fp $ f a -err :: Show a => FilePath -> a -> Errors -err fp d = [(fp, show d)] +instance Foldable (ReifiedTemplate c) where + foldMap f (ReifiedTemplate _ _ a) = f a -processFile :: MonadIO m => FilePath -> FilePath -> ValidateT Errors m Templates -processFile d fp = validate . liftIO $ parseFile' (d fp) +instance Traversable (ReifiedTemplate c) where + traverse f (ReifiedTemplate p fp a) = fmap (ReifiedTemplate p fp) $ f a - where parseFile' f = fmap validateResult (parseFile f) - validateResult (Success t) = OK (tpl fp t) - validateResult (Failure e) = NotOK (err fp e) +type Errors = MonoidalMap FilePath (Set String) + +processFile + :: FilePath + -> ReifiedTemplate c () + -> ValidateT Errors IO (HashMap FilePath (ReifiedTemplate c Template)) +processFile d t@(ReifiedTemplate _ fp _) + = validate + $ fmap + ( either + (NotOK . MM.singleton fp . S.singleton) + (OK . HM.singleton fp) + ) + $ instantiate d t + + +-- | Parse a 'ReifiedTemplate'. This is like 'Text.EDE.parseFile', but works +-- directly over 'ReifiedTemplate's and plays more nicely with servant-ede. +-- +-- @since 1.0.0.0 +instantiate + :: FilePath + -- ^ Template directory + -> ReifiedTemplate c () + -> IO (Either String (ReifiedTemplate c Template)) +instantiate d (ReifiedTemplate p fp ()) + = fmap (fmap (ReifiedTemplate p fp) . eitherResult) + $ parseFile + $ d fp + diff --git a/src/Servant/EDE/Internal.hs b/src/Servant/EDE/Internal.hs --- a/src/Servant/EDE/Internal.hs +++ b/src/Servant/EDE/Internal.hs @@ -1,10 +1,8 @@ module Servant.EDE.Internal - ( module Servant.EDE.Internal.Reify - , module Servant.EDE.Internal.ToObject + ( 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 diff --git a/src/Servant/EDE/Internal/Reify.hs b/src/Servant/EDE/Internal/Reify.hs deleted file mode 100644 --- a/src/Servant/EDE/Internal/Reify.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# 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 diff --git a/src/Servant/EDE/Internal/ToObject.hs b/src/Servant/EDE/Internal/ToObject.hs --- a/src/Servant/EDE/Internal/ToObject.hs +++ b/src/Servant/EDE/Internal/ToObject.hs @@ -5,9 +5,11 @@ -- {-# LANGUAGE OverloadedStrings #-} module Servant.EDE.Internal.ToObject where +import Control.Arrow import Data.Aeson -import Data.HashMap.Strict -import Data.Monoid +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Key as Key +import qualified Data.HashMap.Strict as HashMap import Data.Text import GHC.Generics @@ -36,22 +38,30 @@ -- > instance ToObject User -- -- This will generate an equivalent instance to the previous one. +-- +-- @since 0.4 class ToObject a where -- | Turn values of type @a@ into JSON 'Object's. -- - -- @ + -- @ -- -- Reminder: - -- type Object = 'HashMap' 'Text' 'Value' + -- type Object = 'KeyMap' 'Value' -- @ toObject :: a -> Object - + default toObject :: (Generic a, GToObject (Rep a)) => a -> Object toObject = genericToObject -instance ToObject (HashMap Text Value) where +instance ToObject (HashMap.HashMap Text Value) where + toObject hm = KeyMap.fromList [(Key.fromText k, v) | (k,v) <- HashMap.toList hm] + +instance ToObject (KeyMap.KeyMap Value) where toObject = id +instance ToObject () where + toObject = mempty + class GToObject f where gtoObject :: f a -> Object @@ -72,9 +82,17 @@ 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) + gtoObject s@(M1 (K1 x)) = KeyMap.fromList [(fieldname, value)] + where fieldname = Key.fromText (pack (selName s)) value = toJSON x genericToObject :: (Generic a, GToObject (Rep a)) => a -> Object genericToObject = gtoObject . from + + +-- | Convert from 'ToObject' into something that EDE can handle directly. +-- +-- @since 1.0.0.0 +toEdeObject :: ToObject a => a -> HashMap.HashMap Text Value +toEdeObject = HashMap.fromList . fmap (first Key.toText) . KeyMap.toList . toObject + diff --git a/src/Servant/EDE/Internal/Validate.hs b/src/Servant/EDE/Internal/Validate.hs --- a/src/Servant/EDE/Internal/Validate.hs +++ b/src/Servant/EDE/Internal/Validate.hs @@ -8,7 +8,6 @@ #endif import Data.Functor.Compose -import Data.Semigroup data Validated e a = OK a | NotOK e deriving (Eq, Show)