From 079ee7d4631bb5ccaac29d0aba3f22dffbda3a94 Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Sun, 13 Nov 2022 19:28:14 +0100 Subject: [PATCH 1/7] tried stuff --- aoc-proxy.cabal | 5 ++++- config.json | 4 ++++ src/Common.hs | 5 ++++- src/Config.hs | 2 ++ src/Main.hs | 48 +++++++++++++++++++++++++++++++++--------------- src/Routes.hs | 12 ++++++------ src/Templates.hs | 16 ++++++++++++---- 7 files changed, 65 insertions(+), 27 deletions(-) create mode 100644 config.json diff --git a/aoc-proxy.cabal b/aoc-proxy.cabal index 598bbc9..47b1575 100644 --- a/aoc-proxy.cabal +++ b/aoc-proxy.cabal @@ -35,12 +35,15 @@ executable aoc-proxy split -any, hashable -any, parsec -any, + aeson -any, + yaml -any, + mtl -any, + utf8-string -any, directory -any, bytestring >=0.10.4, binary ==0.8.9.1, base -any, text -any, - blaze-html -any, ginger >=0.10.4.0 hs-source-dirs: src default-language: Haskell2010 diff --git a/config.json b/config.json new file mode 100644 index 0000000..8cb410f --- /dev/null +++ b/config.json @@ -0,0 +1,4 @@ +{ + "hello": "world", + "yeet": "blue" +} diff --git a/src/Common.hs b/src/Common.hs index c5a8d4e..86feb9e 100644 --- a/src/Common.hs +++ b/src/Common.hs @@ -9,10 +9,11 @@ import System.IO (IOMode(ReadMode), openFile, hGetContents) import Data.List (zip, isPrefixOf) import Data.List.Split +import qualified Data.Aeson as JSON + filename :: FilePath -> FilePath filename fn = last (splitOn "/" fn) - getFile :: FilePath -> HashMap FilePath String -> Maybe String getFile fn dir = HashMap.lookup (filename fn) dir @@ -31,3 +32,5 @@ loadFile fn = do f <- openFile fn ReadMode hGetContents f + + diff --git a/src/Config.hs b/src/Config.hs index b83a904..1cde085 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -15,4 +15,6 @@ templatesDir :: FilePath templatesDir = "templates" +configFile :: FilePath +configFile = "config.json" diff --git a/src/Main.hs b/src/Main.hs index 43cc569..f5f59b6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,10 +12,6 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Lazy (unpack) import Happstack.Lite -import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label) -import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A import Data.HashMap.Strict (fromList, HashMap) import qualified Data.HashMap.Strict as HashMap @@ -25,21 +21,43 @@ import Data.List (zip) import System.Exit (exitFailure) +import Text.Ginger +import Text.Ginger.GVal +import Text.Ginger.Html +import qualified Data.Aeson as JSON +import qualified Data.Yaml as YAML + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.UTF8 as BLU +import Control.Monad.Writer + main :: IO () main = do putStrLn "===============================================================================" - -- Read Templates - rawTemplates <- readDir templatesDir - let templates = parseTemplates rawTemplates - case templates of + -- Read Config + configFileData <- loadFile configFile + let configJSON = JSON.eitherDecode (BLU.fromString configFileData) + case configJSON of Left errs -> do - putStrLn "Failed parsing templates:" - printParseErrors errs + putStrLn "Failed parsing config JSON:" + print errs exitFailure - Right templates' -> do - - -- Serve Files - putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") - serve (Just aocServerConfig) (routes templates') + Right configJSON' -> do + let configGVal = rawJSONToGVal configJSON' + putStrLn ("Using config: " ++ (show configGVal)) + + -- Read Templates + rawTemplates <- readDir templatesDir + let templates = parseTemplates rawTemplates + case templates of + Left errs -> do + putStrLn "Failed parsing templates:" + printParseErrors errs + exitFailure + Right templates' -> do + + -- Serve Files + putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") + serve (Just aocServerConfig) (routes templates' configGVal) diff --git a/src/Routes.hs b/src/Routes.hs index 5e173a7..1d9cbe4 100644 --- a/src/Routes.hs +++ b/src/Routes.hs @@ -21,18 +21,18 @@ instance ToMessage Html where toContentType _ = B.pack "text/html; charset=UTF-8" toMessage = toMessage . htmlSource -routes :: Templates -> ServerPart Response -routes templates = msum [ +routes :: Templates -> Scope -> ServerPart Response +routes templates scope = msum [ dir "static" $ handlerFileServing - , handler templates "index.html" Nothing + , handler templates scope "index.html" Nothing ] -handler :: Templates -> TemplateName -> Maybe (a -> ServerPart a) -> ServerPart Response -handler templates templateName extraHandlerMay = handler' (lookupTemplate templateName templates) extraHandlerMay +handler :: Templates -> Scope -> TemplateName -> Maybe (a -> ServerPart a) -> ServerPart Response +handler templates scope templateName extraHandlerMay = handler' (lookupTemplate templateName templates) extraHandlerMay where handler' Nothing _ = internalServerError (strToResponse "Template lookup failed.") handler' (Just template) (Just extraHandler) = ok (strToResponse "TODO extraHandler") - handler' (Just template) Nothing = ok (toResponse (render template HashMap.empty)) + handler' (Just template) Nothing = ok (toResponse (render template scope)) strToResponse :: String -> Response strToResponse str = toResponse str diff --git a/src/Templates.hs b/src/Templates.hs index 47c53bc..015c17b 100644 --- a/src/Templates.hs +++ b/src/Templates.hs @@ -21,6 +21,8 @@ import Text.Ginger (SourcePos ,makeContextHtml ,formatParserError ,VarName + ,asHashMap + ,Run ) --(Source, IncludeResolver, peErrorMessage, peSourcePosition, SourceName, SourcePos, ParserError, makeContextHtml, Template, toGVal, runGinger, parseGingerFile, VarName) import Text.Ginger.GVal (ToGVal, GVal) @@ -28,6 +30,9 @@ import qualified Text.Ginger.AST (Template (..)) import Text.Ginger.Html import Text.Parsec.Pos (initialPos) +import Control.Monad.Writer + +type Scope = GVal (Writer Html) type Template = Text.Ginger.AST.Template SourcePos type TemplateName = SourceName type Templates = HashMap TemplateName Template @@ -74,11 +79,14 @@ lookupTemplate templateName templates = HashMap.lookup (filename templateName) t -- Given a Template and a HashMap of context, render the template to Html -render :: Template -> HashMap VarName Text -> Html -render template contextMap = runGinger context template +render :: Template -> Scope -> Html +render template scope = runGinger context template where - contextLookup = flip scopeLookup contextMap - context = makeContextHtml contextLookup + scopeHashMap = asHashMap scope + context = makeContextHtml (contextLookup scopeHashMap) + contextLookup :: Maybe (HashMap Text (GVal (Run p (Writer Html) Html))) -> (VarName -> GVal (Run p (Writer Html) Html)) + contextLookup (Just scopeHashMap') = flip (HashMap.findWithDefault (toGVal Nothing)) scopeHashMap' + contextLookup Nothing = flip (HashMap.findWithDefault (toGVal Nothing)) HashMap.empty --in htmlSource $ runGinger context template -- GitLab From cf491bd159977794020231921b1525aea6fc7b02 Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Wed, 16 Nov 2022 21:11:00 +0100 Subject: [PATCH 2/7] stuff --- aoc-proxy.cabal | 3 ++- src/Templates.hs | 14 ++++++++++---- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/aoc-proxy.cabal b/aoc-proxy.cabal index 47b1575..7d8198e 100644 --- a/aoc-proxy.cabal +++ b/aoc-proxy.cabal @@ -41,9 +41,10 @@ executable aoc-proxy utf8-string -any, directory -any, bytestring >=0.10.4, - binary ==0.8.9.1, + binary -any, base -any, text -any, + data-default -any, ginger >=0.10.4.0 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Templates.hs b/src/Templates.hs index 015c17b..3fcf6c9 100644 --- a/src/Templates.hs +++ b/src/Templates.hs @@ -23,6 +23,7 @@ import Text.Ginger (SourcePos ,VarName ,asHashMap ,Run + ,liftRun ) --(Source, IncludeResolver, peErrorMessage, peSourcePosition, SourceName, SourcePos, ParserError, makeContextHtml, Template, toGVal, runGinger, parseGingerFile, VarName) import Text.Ginger.GVal (ToGVal, GVal) @@ -82,14 +83,19 @@ lookupTemplate templateName templates = HashMap.lookup (filename templateName) t render :: Template -> Scope -> Html render template scope = runGinger context template where +-- scopeHashMap :: Maybe (HashMap Text (GVal (Run p (Writer Html) Html))) scopeHashMap = asHashMap scope - context = makeContextHtml (contextLookup scopeHashMap) - contextLookup :: Maybe (HashMap Text (GVal (Run p (Writer Html) Html))) -> (VarName -> GVal (Run p (Writer Html) Html)) - contextLookup (Just scopeHashMap') = flip (HashMap.findWithDefault (toGVal Nothing)) scopeHashMap' - contextLookup Nothing = flip (HashMap.findWithDefault (toGVal Nothing)) HashMap.empty + context = makeContextHtml $ contextLookup scopeHashMap + + + +contextLookup :: Maybe (HashMap Text (GVal (Writer Html))) -> (VarName -> GVal (Run p (Writer Html) Html)) +contextLookup (Just scopeHashMap') = flip (HashMap.findWithDefault (toGVal Nothing)) scopeHashMap' +contextLookup Nothing = \_ -> fmap liftRun $ toGVal Nothing --in htmlSource $ runGinger context template + -- Wrapper around HashMap.lookup that applies toGVal to the value found. -- Any value referenced in a template, returned from within a template, or used -- in a template context, will be a GVal -- GitLab From 24feefebd6f12da54d5e0fe1db7aced307f3fca9 Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Wed, 16 Nov 2022 21:44:42 +0100 Subject: [PATCH 3/7] stuff --- src/Templates.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Templates.hs b/src/Templates.hs index 3fcf6c9..f222246 100644 --- a/src/Templates.hs +++ b/src/Templates.hs @@ -91,7 +91,7 @@ render template scope = runGinger context template contextLookup :: Maybe (HashMap Text (GVal (Writer Html))) -> (VarName -> GVal (Run p (Writer Html) Html)) contextLookup (Just scopeHashMap') = flip (HashMap.findWithDefault (toGVal Nothing)) scopeHashMap' -contextLookup Nothing = \_ -> fmap liftRun $ toGVal Nothing +contextLookup Nothing = \_ -> toGVal Nothing --in htmlSource $ runGinger context template -- GitLab From d29ad9b21d51c345e2f92e2a7627d7ca551a5e94 Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Wed, 16 Nov 2022 21:44:56 +0100 Subject: [PATCH 4/7] stuff --- config.json | 3 ++- src/Main.hs | 28 +++++++++++++++------------- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/config.json b/config.json index 8cb410f..62f699e 100644 --- a/config.json +++ b/config.json @@ -1,4 +1,5 @@ { "hello": "world", - "yeet": "blue" + "yeet": "blue", + "yeet2": 12.3 } diff --git a/src/Main.hs b/src/Main.hs index f5f59b6..29dea70 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeApplications #-} module Main where @@ -46,18 +46,20 @@ main = do Right configJSON' -> do let configGVal = rawJSONToGVal configJSON' putStrLn ("Using config: " ++ (show configGVal)) + print (fromGVal configGVal) + - -- Read Templates - rawTemplates <- readDir templatesDir - let templates = parseTemplates rawTemplates - case templates of - Left errs -> do - putStrLn "Failed parsing templates:" - printParseErrors errs - exitFailure - Right templates' -> do + ---- Read Templates + --rawTemplates <- readDir templatesDir + --let templates = parseTemplates rawTemplates + --case templates of + -- Left errs -> do + -- putStrLn "Failed parsing templates:" + -- printParseErrors errs + -- exitFailure + -- Right templates' -> do - -- Serve Files - putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") - serve (Just aocServerConfig) (routes templates' configGVal) + -- -- Serve Files + -- putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") + -- serve (Just aocServerConfig) (routes templates' configGVal) -- GitLab From 172f671e6ecbf01d55438431302c7df4166f6097 Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Thu, 17 Nov 2022 18:05:29 +0100 Subject: [PATCH 5/7] fixed Templates.hs --- src/Templates.hs | 89 ++++++++++++++---------------------------------- 1 file changed, 25 insertions(+), 64 deletions(-) diff --git a/src/Templates.hs b/src/Templates.hs index f222246..f2e4b97 100644 --- a/src/Templates.hs +++ b/src/Templates.hs @@ -4,41 +4,37 @@ module Templates where import Common -import Data.HashMap.Strict (fromList, HashMap, elems) -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable -import Data.Text (Text) -import System.Exit (exitFailure) -import System.IO (IOMode(ReadMode), openFile, hGetContents) -import System.IO.Error (tryIOError) -import Text.Ginger (SourcePos +import Text.Ginger ( + easyRender + ,SourcePos ,SourceName ,ParserError(..) ,Statement(NullS) ,parseGingerFile - ,runGinger - ,toGVal - ,makeContextHtml ,formatParserError - ,VarName - ,asHashMap ,Run - ,liftRun + ,rawJSONToGVal ) - --(Source, IncludeResolver, peErrorMessage, peSourcePosition, SourceName, SourcePos, ParserError, makeContextHtml, Template, toGVal, runGinger, parseGingerFile, VarName) import Text.Ginger.GVal (ToGVal, GVal) -import qualified Text.Ginger.AST (Template (..)) import Text.Ginger.Html +import qualified Text.Ginger.AST (Template (..)) + import Text.Parsec.Pos (initialPos) +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (fromList, HashMap, elems) +import Data.Text (Text) +import Data.Aeson (toJSON, ToJSON) + import Control.Monad.Writer -type Scope = GVal (Writer Html) type Template = Text.Ginger.AST.Template SourcePos type TemplateName = SourceName type Templates = HashMap TemplateName Template type TemplateErrors = [(Maybe String, ParserError)] + + printParseErrors :: TemplateErrors -> IO () printParseErrors [(templateSource, err)] = putStrLn ("\ESC[31m" ++ "ERROR: " ++ (formatParserError templateSource err) ++ "\ESC[0m") printParseErrors (err:errs) = do @@ -47,6 +43,8 @@ printParseErrors (err:errs) = do printParseErrors _ = putStrLn "No errors." + + parseTemplates :: HashMap FilePath String -> Either TemplateErrors Templates parseTemplates templatesDir = if (null errors) then (Right templates) @@ -79,54 +77,17 @@ lookupTemplate templateName templates = HashMap.lookup (filename templateName) t --- Given a Template and a HashMap of context, render the template to Html -render :: Template -> Scope -> Html -render template scope = runGinger context template - where --- scopeHashMap :: Maybe (HashMap Text (GVal (Run p (Writer Html) Html))) - scopeHashMap = asHashMap scope - context = makeContextHtml $ contextLookup scopeHashMap - - - -contextLookup :: Maybe (HashMap Text (GVal (Writer Html))) -> (VarName -> GVal (Run p (Writer Html) Html)) -contextLookup (Just scopeHashMap') = flip (HashMap.findWithDefault (toGVal Nothing)) scopeHashMap' -contextLookup Nothing = \_ -> toGVal Nothing - --in htmlSource $ runGinger context template - - - --- Wrapper around HashMap.lookup that applies toGVal to the value found. --- Any value referenced in a template, returned from within a template, or used --- in a template context, will be a GVal -scopeLookup - :: (Hashable k, Eq k, ToGVal m b) - => k -> HashMap.HashMap k b -> GVal m -scopeLookup key context = toGVal $ HashMap.lookup key context - - -loadFileMay :: FilePath -> IO (Maybe String) -loadFileMay fn = - tryIOError (loadFile fn) >>= \e -> - case e of - Right contents -> return (Just contents) - Left _ -> return Nothing +-- https://github.com/tdammers/ginger/issues/65 +renderTemplateText :: ToJSON c => Template -> c -> Either Text Text +renderTemplateText template ctx = do + let ctxGVal :: GVal (Run SourcePos (Writer Text) Text) = rawJSONToGVal $ toJSON ctx + let r :: Text = easyRender ctxGVal template + return r +renderTemplate :: ToJSON c => Template -> c -> Either Text Html +renderTemplate template ctx = convertRightToHtml (renderTemplateText template ctx) where - loadFile :: FilePath -> IO String - loadFile fn' = openFile fn' ReadMode >>= hGetContents - - ----- Assuming there's an html file called "base.html" in the current directory and ----- that html file's contents are `Hi, {{ name }}`, attempt to parse "base.html" ----- and print the rendered template ----- >>> run ----- "Hi, Alice" ---main :: IO () ---main = do --- template <- parseGingerFile loadFileMay "base.html" --- case template of --- Left err -> print err >> exitFailure --- Right template' -> print $ render template' sampleContext + convertRightToHtml (Left err) = Left err + convertRightToHtml (Right rendered) = Right (unsafeRawHtml rendered) -- GitLab From 2c9a7312c772c4f49debe8f576efa4f0a62e4aef Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Thu, 17 Nov 2022 18:06:03 +0100 Subject: [PATCH 6/7] updated Routes.hs --- src/Routes.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Routes.hs b/src/Routes.hs index 1d9cbe4..c884b70 100644 --- a/src/Routes.hs +++ b/src/Routes.hs @@ -16,23 +16,27 @@ import qualified Data.ByteString.Char8 as B import Text.Ginger.Html (Html, htmlSource) +import Data.Aeson (ToJSON) instance ToMessage Html where toContentType _ = B.pack "text/html; charset=UTF-8" toMessage = toMessage . htmlSource -routes :: Templates -> Scope -> ServerPart Response -routes templates scope = msum [ +routes :: ToJSON c => Templates -> c -> ServerPart Response +routes templates context = msum [ dir "static" $ handlerFileServing - , handler templates scope "index.html" Nothing + , handler templates context "index.html" Nothing ] -handler :: Templates -> Scope -> TemplateName -> Maybe (a -> ServerPart a) -> ServerPart Response -handler templates scope templateName extraHandlerMay = handler' (lookupTemplate templateName templates) extraHandlerMay +handler :: ToJSON c => Templates -> c -> TemplateName -> Maybe (a -> ServerPart a) -> ServerPart Response +handler templates context templateName extraHandlerMay = handler' (lookupTemplate templateName templates) extraHandlerMay where handler' Nothing _ = internalServerError (strToResponse "Template lookup failed.") handler' (Just template) (Just extraHandler) = ok (strToResponse "TODO extraHandler") - handler' (Just template) Nothing = ok (toResponse (render template scope)) + handler' (Just template) Nothing = handler'' (renderTemplate template context) + + handler'' (Left err) = internalServerError (toResponse err) + handler'' (Right renderedTemplate) = ok (toResponse renderedTemplate) strToResponse :: String -> Response strToResponse str = toResponse str -- GitLab From 648043a25b56e0add3e33300a915b8dddb68ec2c Mon Sep 17 00:00:00 2001 From: Jake <j.vondoemming@stud.uni-goettingen.de> Date: Thu, 17 Nov 2022 18:06:20 +0100 Subject: [PATCH 7/7] updated Main.hs --- src/Main.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 29dea70..a851327 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -46,20 +46,19 @@ main = do Right configJSON' -> do let configGVal = rawJSONToGVal configJSON' putStrLn ("Using config: " ++ (show configGVal)) - print (fromGVal configGVal) - ---- Read Templates - --rawTemplates <- readDir templatesDir - --let templates = parseTemplates rawTemplates - --case templates of - -- Left errs -> do - -- putStrLn "Failed parsing templates:" - -- printParseErrors errs - -- exitFailure - -- Right templates' -> do + -- Read Templates + rawTemplates <- readDir templatesDir + let templates = parseTemplates rawTemplates + case templates of + Left errs -> do + putStrLn "Failed parsing templates:" + printParseErrors errs + exitFailure + Right templates' -> do - -- -- Serve Files - -- putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") - -- serve (Just aocServerConfig) (routes templates' configGVal) + -- Serve Files + putStrLn ("Hosting aoc-proxy on http://localhost:" ++ (show (port aocServerConfig)) ++ " ...") + serve (Just aocServerConfig) (routes templates' configGVal) -- GitLab