{-# 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: -- -- > 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)