From 4aa6c818da94bc9ebb3cd3b5588caabede14a725 Mon Sep 17 00:00:00 2001 From: Matthew Chan Date: Mon, 18 Jun 2018 22:11:50 -0700 Subject: [PATCH 1/5] templates first stab --- lio-http-server/lio-http-server.cabal | 8 +++-- .../src/LIO/HTTP/Server/Controller.hs | 33 +++++++------------ .../src/LIO/HTTP/Server/Responses.hs | 25 +++++++------- lio-http-server/stack.yaml | 1 + 4 files changed, 31 insertions(+), 36 deletions(-) diff --git a/lio-http-server/lio-http-server.cabal b/lio-http-server/lio-http-server.cabal index 2794c08..dba4fad 100644 --- a/lio-http-server/lio-http-server.cabal +++ b/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 diff --git a/lio-http-server/src/LIO/HTTP/Server/Controller.hs b/lio-http-server/src/LIO/HTTP/Server/Controller.hs index f906ac9..254da00 100644 --- a/lio-http-server/src/LIO/HTTP/Server/Controller.hs +++ b/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) diff --git a/lio-http-server/src/LIO/HTTP/Server/Responses.hs b/lio-http-server/src/LIO/HTTP/Server/Responses.hs index cf93057..81f3829 100644 --- a/lio-http-server/src/LIO/HTTP/Server/Responses.hs +++ b/lio-http-server/src/LIO/HTTP/Server/Responses.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes,TemplateHaskell #-} {- @@ -45,7 +46,8 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import LIO.HTTP.Server - +import Text.Mustache +import LIO.HTTP.Server.Frankie.Templates -- | Type alias for 'S8.ByteString' type ContentType = S8.ByteString @@ -81,17 +83,16 @@ 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 - "\n\ - \\n\ - \301 Moved Permanently\n\ - \\n\ - \

Moved Permanently

\n\ - \

The document has moved here\n\ - \\n"] + where html = applyTemplate ("url" ~> url) + [mustache| + + + 301 Moved Permanently + +

Moved Permanently

+

The document has moved here + + |] -- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL. redirectTo :: S8.ByteString -> Response diff --git a/lio-http-server/stack.yaml b/lio-http-server/stack.yaml index 57d63d4..4709374 100644 --- a/lio-http-server/stack.yaml +++ b/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 From cd16c00ae15f9915de05834f4d8fcea45d7622ac Mon Sep 17 00:00:00 2001 From: Matthew Chan Date: Mon, 18 Jun 2018 22:20:39 -0700 Subject: [PATCH 2/5] more responses --- .../src/LIO/HTTP/Server/Responses.hs | 128 +++++++++--------- 1 file changed, 66 insertions(+), 62 deletions(-) diff --git a/lio-http-server/src/LIO/HTTP/Server/Responses.hs b/lio-http-server/src/LIO/HTTP/Server/Responses.hs index 81f3829..3a83239 100644 --- a/lio-http-server/src/LIO/HTTP/Server/Responses.hs +++ b/lio-http-server/src/LIO/HTTP/Server/Responses.hs @@ -85,92 +85,96 @@ movedTo :: String -> Response movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html where html = applyTemplate ("url" ~> url) [mustache| - - - 301 Moved Permanently - -

Moved Permanently

-

The document has moved here - + + + 301 Moved Permanently + +

Moved Permanently

+

The document has moved here + |] -- | 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 - "\n\ - \\n\ - \303 See Other\n\ - \\n\ - \

See Other

\n\ - \

The document has moved here\n\ - \\n"] + where html = applyTemplate ("url" ~> S8.unpack url) + [mustache| + + + 303 See Other + +

See Other

+

The document has moved here + + |] -- | Returns a 400 (Bad Request) 'Response'. badRequest :: Response badRequest = mkHtmlResponse status400 [] html - where html = L8.concat - [L8.pack - "\n\ - \\n\ - \400 Bad Request\n\ - \\n\ - \

Bad Request

\n\ - \

Your request could not be understood.

\n\ - \\n"] + where html = applyTemplate () + [mustache| + + + 400 Bad Request + +

Bad Request

+

Your request could not be understood.

+ + |] -- | 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 - "\n\ - \\n\ - \401 Authorization Required\n\ - \\n\ - \

Authorization Required

\n\ - \\n"] + where html = applyTemplate () + [mustache| + + + 401 Authorization Required + +

Authorization Required

+ + |] -- | Returns a 403 (Forbidden) 'Response'. forbidden :: Response forbidden = mkHtmlResponse status403 [] html - where html = L8.concat - [L8.pack - "\n\ - \\n\ - \403 Forbidden\n\ - \\n\ - \

Forbidden

\n\ - \

You don't have permission to access this page.

\n\ - \\n"] + where html = applyTemplate () + [mustache| + + + 403 Forbidden + +

Forbidden

+

You don't have permission to access this page.

+ + |] -- | Returns a 404 (Not Found) 'Response'. notFound :: Response notFound = mkHtmlResponse status404 [] html - where html = L8.concat - [L8.pack - "\n\ - \\n\ - \404 Not Found\n\ - \\n\ - \

Not Found

\n\ - \

The requested URL was not found on this server.

\n\ - \\n"] + where html = applyTemplate () + [mustache| + + + 404 Not Found + +

Not Found

+

The requested URL was not found on this server.

+ + |] -- | Returns a 500 (Server Error) 'Response'. serverError :: L8.ByteString -> Response serverError message = mkHtmlResponse status500 [] html - where html = L8.concat - [L8.pack - "\n\ - \\n\ - \500 Internal Server Error\n\ - \\n\ - \

Internal Server Error

\n\ - \

", message, - "

\n"] + where html = applyTemplate ("message" ~> L8.unpack message) + [mustache| + + + 500 Internal Server Error + +

Internal Server Error

+

{{message}} +

+ |] From 3f399537edcfa54933c3d4331f79b71c1c82ff3b Mon Sep 17 00:00:00 2001 From: Matthew Chan Date: Mon, 18 Jun 2018 22:27:14 -0700 Subject: [PATCH 3/5] close tags --- lio-http-server/src/LIO/HTTP/Server/Responses.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lio-http-server/src/LIO/HTTP/Server/Responses.hs b/lio-http-server/src/LIO/HTTP/Server/Responses.hs index 3a83239..dea4310 100644 --- a/lio-http-server/src/LIO/HTTP/Server/Responses.hs +++ b/lio-http-server/src/LIO/HTTP/Server/Responses.hs @@ -90,7 +90,7 @@ movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html 301 Moved Permanently

Moved Permanently

-

The document has moved here +

The document has moved here

|] @@ -104,7 +104,7 @@ redirectTo url = mkHtmlResponse status303 [(hLocation, url)] html 303 See Other

See Other

-

The document has moved here +

The document has moved here

|] @@ -175,6 +175,6 @@ serverError message = mkHtmlResponse status500 [] html 500 Internal Server Error

Internal Server Error

-

{{message}} -

+

{{message}}

+ |] From 33920c921ef338e6fff7a38ae91ee323c490c65b Mon Sep 17 00:00:00 2001 From: Matthew Chan Date: Mon, 18 Jun 2018 22:29:42 -0700 Subject: [PATCH 4/5] shuffle imports --- lio-http-server/src/LIO/HTTP/Server/Responses.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lio-http-server/src/LIO/HTTP/Server/Responses.hs b/lio-http-server/src/LIO/HTTP/Server/Responses.hs index dea4310..3283559 100644 --- a/lio-http-server/src/LIO/HTTP/Server/Responses.hs +++ b/lio-http-server/src/LIO/HTTP/Server/Responses.hs @@ -44,9 +44,9 @@ 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 Text.Mustache import LIO.HTTP.Server.Frankie.Templates -- | Type alias for 'S8.ByteString' From f53c4ed44bd79bf4bcf8622d3e49f2b470180d49 Mon Sep 17 00:00:00 2001 From: Matthew Chan Date: Tue, 19 Jun 2018 13:47:42 -0700 Subject: [PATCH 5/5] new files --- lio-http-server/README.md | 0 .../src/LIO/HTTP/Server/Frankie/Templates.hs | 84 +++++++++++++++++++ 2 files changed, 84 insertions(+) create mode 100644 lio-http-server/README.md create mode 100644 lio-http-server/src/LIO/HTTP/Server/Frankie/Templates.hs diff --git a/lio-http-server/README.md b/lio-http-server/README.md new file mode 100644 index 0000000..e69de29 diff --git a/lio-http-server/src/LIO/HTTP/Server/Frankie/Templates.hs b/lio-http-server/src/LIO/HTTP/Server/Frankie/Templates.hs new file mode 100644 index 0000000..82e4081 --- /dev/null +++ b/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