Mustache templates

lio-http-server/lio-http-server.cabal

@@ -20,7 +20,8 @@ library
                        LIO.HTTP.Server.Responses,
                        LIO.HTTP.Server.Controller,
                        LIO.HTTP.Server.Frankie,
-                       LIO.HTTP.Server.Frankie.Loggers
+                       LIO.HTTP.Server.Frankie.Loggers,
+                       LIO.HTTP.Server.Frankie.Templates
   build-depends:       ansi-terminal >= 0.6.2.1,
                        base          >= 4.7 && < 6,
                        bytestring    >= 0.10,
@@ -32,7 +33,10 @@ library
                        warp          >= 3.2.11.1,
                        time          >= 1.6.0.1,
                        transformers  >= 0.5.2.0,
-                       mtl           >= 2.2.1
+                       mtl           >= 2.2.1,
+                       regex-tdfa    >= 1.2.0,
+                       mustache      >= 2.3.0,
+                       template-haskell
   default-language:    Haskell2010
   GHC-options: -Wall -fno-warn-orphans
 

lio-http-server/src/LIO/HTTP/Server/Controller.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -71,12 +73,7 @@ import qualified Data.Text.Encoding as Text
 -- running and has an intermediate result encoded by 'Working'.
 data ControllerStatus a = Done Response
                         | Working a
-                        deriving (Eq)
-
-instance Functor ControllerStatus where
-  fmap f cs = case cs of
-    Working a -> Working $ f a
-    Done r    -> Done r
+                        deriving (Eq, Functor)
 
 -- | The Controller monad is used to encode stateful HTTP controller
 -- computations.  The monad is a reader monad that provides the current request
@@ -86,14 +83,9 @@ instance Functor ControllerStatus where
 --
 -- Within the Controller monad, the remainder of the computation can be
 -- short-circuited by 'respond'ing with a 'Response'.
-data Controller s m a = Controller {
+newtype Controller s m a = Controller {
  runController :: s -> Logger m -> Request m -> m (ControllerStatus a, s)
-} deriving (Typeable)
-
-instance Functor m => Functor (Controller s m) where
-  fmap f (Controller act) = Controller $ \s0 logger req ->
-    go `fmap` act s0 logger req
-    where go (cs, st) = (f `fmap` cs, st)
+} deriving (Typeable, Functor)
 
 instance (Monad m, Functor m) => Applicative (Controller s m) where
   pure = return
@@ -193,7 +185,7 @@ queryParams :: (WebMonad m, Parseable a)
             => Strict.ByteString -- ^ Parameter name
             -> Controller s m [a]
 queryParams varName = do
-  query <- liftM reqQueryString request
+  query <- reqQueryString <$> request
   return $ mapMaybe go query
     where go (name, mparam) = if name == varName
                                 then mparam >>= parseBS
@@ -204,7 +196,7 @@ queryParams varName = do
 -- terms of the other, so only one definition is necessary.
 class Typeable a => Parseable a where
   -- | Try parsing 'Strict.ByteString' as @a@.
-  parseBS   :: Strict.ByteString -> Maybe a
+  parseBS :: Strict.ByteString -> Maybe a
   parseBS bs  = case Text.decodeUtf8' bs of
                   Left _  -> Nothing
                   Right t -> parseText t
@@ -231,7 +223,7 @@ instance {-# OVERLAPPABLE #-} (Read a, Typeable a) => Parseable a where
 -- present in the HTTP request.
 requestHeader :: WebMonad m
               => HeaderName -> Controller s m (Maybe Strict.ByteString)
-requestHeader name = request >>= return . lookup name . reqHeaders
+requestHeader name = lookup name . reqHeaders <$> request
 
 -- | Redirect back to the referer. If the referer header is not present
 -- 'redirectTo' root (i.e., @\/@).
@@ -243,11 +235,8 @@ redirectBack = redirectBackOr (redirectTo "/")
 redirectBackOr :: WebMonad m
                => Response -- ^ Fallback response
                -> Controller s m ()
-redirectBackOr def = do
-  mrefr <- requestHeader "referer"
-  case mrefr of
-    Just refr -> respond $ redirectTo refr
-    Nothing   -> respond def
+redirectBackOr def =
+  requestHeader "referer" >>= respond . maybe def redirectTo
 
 -- | Log text using app-specific logger.
 log :: WebMonad m => LogLevel -> String -> Controller s m ()
@@ -268,5 +257,5 @@ data LogLevel = EMERGENCY
               | WARNING
               | NOTICE
               | INFO
-              | DEBUG 
+              | DEBUG
               deriving (Show, Eq, Ord)

lio-http-server/src/LIO/HTTP/Server/Frankie/Templates.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE GADTs, DataKinds, QuasiQuotes, TemplateHaskell #-}
+module LIO.HTTP.Server.Frankie.Templates where
+
+import Text.Mustache
+import Data.ByteString.Lazy as LBS
+import Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+applyTemplate :: ToMustache m => m -> Template -> LBS.ByteString
+applyTemplate = fmap (LBS.fromStrict . encodeUtf8) <$> flip substitute
+
+-- a quasiquoter that parses into a Mustache `Template`.
+mustache :: QuasiQuoter
+mustache = QuasiQuoter{quoteExp = myTemplateParser
+                      ,quotePat = qqerr, quoteType=qqerr, quoteDec= qqerr}
+  where
+    qqerr = error "wrong quasiquoter type"
+    myTemplateParser s = case compileTemplate "" (T.pack s) of
+      Left err -> fail $ show err
+      Right template -> sigE [| template |] [t| Template |]
+
+--import Text.Regex
+
+-- https://mustache.github.io/mustache.5.html
+{-
+data Phase = Lex | Parsed
+
+data Chunk (a :: Phase) where
+  RawChunk :: String -> Chunk a
+  VarChunk :: String -> Chunk a
+  SectionBegin :: String -> Chunk 'Lex
+  SectionEnd :: String -> Chunk 'Lex
+  Section :: [Chunk 'Parsed] -> Chunk 'Parsed
+
+newtype Template = Template [Chunk 'Parsed]
+
+lexTemplate :: String -> [Chunk 'Lex]
+lexTemplate s = go (take 2 s == "{{") splits
+  where
+    splits = splitRegex regex s
+    regex = mkRegex "\\{\\{|\\}\\}"
+    -- TODO flesh this out
+    go _ [] = []
+    go True (x:xs) = VarChunk x : go False xs
+    go False (x:xs) = RawChunk x : go True xs
+
+coaleseChunks :: [Chunk 'Lex] -> Template
+coaleseChunks = Template . go []
+  where
+    -- done
+    go _ [] = []
+    -- close section, top of stack
+    go [(SectionBegin b, body)] (SectionEnd e :xs)
+      | e == b = Section (reverse body) : go xs
+      | otherwise = error "unclosed section"
+    -- close section, nested
+    go ((SectionBegin b, body) : stk) (SectionEnd e :xs)
+      | e == b = go (Section (reverse body) : stk) xs
+      | otherwise = error "unclosed section"
+
+    -- open section
+    go stk (SectionBegin b : xs)
+      = go ((SectionBegin b, []) : stk) xs
+
+    -- normal token, nested
+    go ((SectionBegin b, body) : stk) (x : xs)
+      = go ((SectionBegin b, x : body):stk) xs
+
+    -- normal token, top of stack
+    go [] (x:xs) = x : go [] xs
+
+
+parseTemplate :: String -> Template
+parseTemplate = coaleseChunks . lexTemplate
+-}
+
+-- class Templatable a where
+--   insert :: a -> String
+-- instance Templatable String where
+--   insert = id
+-- instance Show a => Templatable a where
+--   insert = show

lio-http-server/src/LIO/HTTP/Server/Responses.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes,TemplateHaskell #-}
 
 {-
 
@@ -43,9 +44,10 @@ module LIO.HTTP.Server.Responses
 
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy.Char8 as L8
+import Text.Mustache
 
 import LIO.HTTP.Server
-
+import LIO.HTTP.Server.Frankie.Templates
 
 -- | Type alias for 'S8.ByteString'
 type ContentType = S8.ByteString
@@ -81,95 +83,98 @@ okXml = ok (S8.pack "application/xml")
 -- that URL.
 movedTo :: String -> Response
 movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>301 Moved Permanently</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Moved Permanently</H1>\n\
-              \<P>The document has moved <A HREF=\""
-             , L8.pack url
-             , L8.pack "\">here</A>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ("url" ~> url)
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>301 Moved Permanently</TITLE>
+                  </HEAD><BODY>
+                  <H1>Moved Permanently</H1>
+                  <P>The document has moved <A HREF="{{url}}">here</A></P>
+                  </BODY></HTML>
+                 |]
 
 -- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.
 redirectTo :: S8.ByteString -> Response
 redirectTo url = mkHtmlResponse status303 [(hLocation, url)] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>303 See Other</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>See Other</H1>\n\
-              \<P>The document has moved <A HREF=\""
-             , L8.fromChunks [url]
-             , L8.pack "\">here</A>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ("url" ~> S8.unpack url)
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>303 See Other</TITLE>
+                  </HEAD><BODY>
+                  <H1>See Other</H1>
+                  <P>The document has moved <A HREF="{{url}}">here</A></P>
+                  </BODY></HTML>
+                 |]
 
 -- | Returns a 400 (Bad Request) 'Response'.
 badRequest :: Response
 badRequest = mkHtmlResponse status400 [] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>400 Bad Request</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Bad Request</H1>\n\
-              \<P>Your request could not be understood.</P>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ()
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>400 Bad Request</TITLE>
+                  </HEAD><BODY>
+                  <H1>Bad Request</H1>
+                  <P>Your request could not be understood.</P>
+                  </BODY></HTML>
+                 |]
 
 -- | Returns a 401 (Authorization Required) 'Response' requiring basic
 -- authentication in the given realm.
 requireBasicAuth :: String -> Response
 requireBasicAuth realm = mkHtmlResponse status401
   [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>401 Authorization Required</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Authorization Required</H1>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ()
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>401 Authorization Required</TITLE>
+                  </HEAD><BODY>
+                  <H1>Authorization Required</H1>
+                  </BODY></HTML>
+                 |]
 
 -- | Returns a 403 (Forbidden) 'Response'.
 forbidden :: Response
 forbidden = mkHtmlResponse status403 [] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>403 Forbidden</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Forbidden</H1>\n\
-              \<P>You don't have permission to access this page.</P>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ()
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>403 Forbidden</TITLE>
+                  </HEAD><BODY>
+                  <H1>Forbidden</H1>
+                  <P>You don't have permission to access this page.</P>
+                  </BODY></HTML>
+                 |]
 
 -- | Returns a 404 (Not Found) 'Response'.
 notFound :: Response
 notFound = mkHtmlResponse status404 [] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>404 Not Found</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Not Found</H1>\n\
-              \<P>The requested URL was not found on this server.</P>\n\
-                       \</BODY></HTML>\n"]
+  where html = applyTemplate ()
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>404 Not Found</TITLE>
+                  </HEAD><BODY>
+                  <H1>Not Found</H1>
+                  <P>The requested URL was not found on this server.</P>
+                  </BODY></HTML>
+                 |]
 
 -- | Returns a 500 (Server Error) 'Response'.
 serverError :: L8.ByteString -> Response
 serverError message = mkHtmlResponse status500 [] html
-  where html = L8.concat
-             [L8.pack
-              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\
-              \<HTML><HEAD>\n\
-              \<TITLE>500 Internal Server Error</TITLE>\n\
-              \</HEAD><BODY>\n\
-              \<H1>Internal Server Error</H1>\n\
-              \<P>", message,
-              "</P></BODY></HTML>\n"]
+  where html = applyTemplate ("message" ~> L8.unpack message)
+                 [mustache|
+                  <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
+                  <HTML><HEAD>
+                  <TITLE>500 Internal Server Error</TITLE>
+                  </HEAD><BODY>
+                  <H1>Internal Server Error</H1>
+                  <P> {{message}} </P>
+                  </BODY></HTML>
+                 |]

lio-http-server/stack.yaml

@@ -4,4 +4,5 @@ packages:
 - .
 extra-deps:
 - lio-0.11.6.0
+- mustache-2.3.0
 resolver: lts-8.8