servant-ede 0.6 → 1.0.0.0
raw patch · 9 files changed
+533/−234 lines, 9 filesdep +QuickCheckdep +containersdep +hspecdep ~aesondep ~basedep ~bytestringnew-component:exe:template-test-examplenew-uploader
Dependencies added: QuickCheck, containers, hspec, monoidal-containers
Dependency ranges changed: aeson, base, bytestring, ede, either, filepath, http-media, http-types, semigroups, servant, servant-server, text, transformers, unordered-containers, vector, warp, xss-sanitize
Files
- README.md +1/−0
- example/example.hs +18/−10
- example/test-example.hs +102/−0
- servant-ede.cabal +42/−21
- src/Servant/EDE.hs +343/−166
- src/Servant/EDE/Internal.hs +1/−3
- src/Servant/EDE/Internal/Reify.hs +0/−25
- src/Servant/EDE/Internal/ToObject.hs +26/−8
- src/Servant/EDE/Internal/Validate.hs +0/−1
README.md view
@@ -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).+
example/example.hs view
@@ -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
+ example/test-example.hs view
@@ -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)]+
servant-ede.cabal view
@@ -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
src/Servant/EDE.hs view
@@ -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+
src/Servant/EDE/Internal.hs view
@@ -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
− src/Servant/EDE/Internal/Reify.hs
@@ -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
src/Servant/EDE/Internal/ToObject.hs view
@@ -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+
src/Servant/EDE/Internal/Validate.hs view
@@ -8,7 +8,6 @@ #endif import Data.Functor.Compose-import Data.Semigroup data Validated e a = OK a | NotOK e deriving (Eq, Show)