From c67538305d4875b75a605bfc1d18fdd3c5f7e3dd Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 4 Sep 2023 20:16:02 +0200 Subject: [PATCH 1/3] WIP: adding servant web server --- .gitignore | 1 + app/Main.hs | 2 ++ server/Routes.hs | 63 +++++++++++++++++++++++++++++++++++++++ server/ServerMain.hs | 19 ++++++++++++ workflow-visualiser.cabal | 14 +++++++-- 5 files changed, 96 insertions(+), 3 deletions(-) create mode 100644 server/Routes.hs create mode 100644 server/ServerMain.hs diff --git a/.gitignore b/.gitignore index 7d4322b..a5cea65 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ # SPDX-License-Identifier: AGPL-3.0-or-later /dist-newstyle +/dsl/dist-newstyle .stack-work CHANGELOG.md test.json diff --git a/app/Main.hs b/app/Main.hs index 542bfb9..72e2982 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -33,6 +33,7 @@ module Main where import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Lazy (toStrict) import Debug.Trace (trace) + import ServerMain (serverMain) --------------------------------------- @@ -45,6 +46,7 @@ module Main where main :: IO () main = getArgs >>= process >>= finish where process :: [String] -> IO Bool + process ["--server"] = serverMain >> return True process [path] = printEvents path >> runParser path >> return True process args@[_, _] = generateJSON args >> return False process args@["--all", src, to] = processDirectory src to >> return False diff --git a/server/Routes.hs b/server/Routes.hs new file mode 100644 index 0000000..a4a4671 --- /dev/null +++ b/server/Routes.hs @@ -0,0 +1,63 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# LANGUAGE DataKinds, + TypeOperators, + FlexibleInstances, + MultiParamTypeClasses, + OverloadedStrings #-} + +module Routes where + +import Servant +import Servant.API +import Servant.Server +import Network.HTTP.Media ((//), (/:)) +import Data.ByteString.Lazy.Internal (ByteString) + + +directory :: FilePath +directory = "." -- Directory of the static files + +data HTML +data HTMLTemplate + +type Home = Get '[HTML] [HTMLTemplate] -- Serve app under / + :<|> "app" :> Get '[HTML] [HTMLTemplate] -- Also serve app under /app + +type RequestFile = Raw -- For serving the workflow definitions & index.json | TODO alternatively keep data after parsing & serve as '[JSON] + +instance Accept HTML where + contentType _ = "text" // "html" + +instance MimeRender HTML ByteString where + mimeRender _ bs = bs + +instance MimeUnrender HTML ByteString where + mimeUnrender _ = Right + +instance MimeRender HTML [HTMLTemplate] where + mimeRender p template = undefined --TODO use encoding function of template library + +instance MimeUnrender HTML [HTMLTemplate] where + mimeUnrender _ bs = Right undefined -- TODO use decoding function + + +mainServer :: Server Home +mainServer = undefined + +userAPI :: Proxy Home +userAPI = Proxy + +workFlows :: Application +workFlows = serve userAPI mainServer + +fileServer :: Server RequestFile +fileServer = serveDirectoryFileServer directory + +staticAPI :: Proxy RequestFile +staticAPI = Proxy + +files :: Application +files = serve staticAPI fileServer \ No newline at end of file diff --git a/server/ServerMain.hs b/server/ServerMain.hs new file mode 100644 index 0000000..4e421a3 --- /dev/null +++ b/server/ServerMain.hs @@ -0,0 +1,19 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module ServerMain where + +import Routes (workFlows, files) +import Network.Wai +import Network.Wai.Handler.Warp ( run ) +import Control.Concurrent + +serverMain :: IO () +serverMain = do + putStrLn "Starting app @ http://localhost:8081/" + mainServerThread <- forkIO $ run 8081 workFlows + putStrLn "Main server is running" + putStrLn "Starting file server @ http://localhost:8080/" + run 8080 files + diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal index ad349d9..bbcc343 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -28,7 +28,9 @@ executable workflow-visualiser other-modules: Workflow, Export, Index, - YamlParser + YamlParser, + ServerMain, + Routes -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -41,6 +43,12 @@ executable workflow-visualiser vector, directory, regex-tdfa, - mtl - hs-source-dirs: app + mtl, + servant, + servant-server, + wai, + warp, + http-media, + shakespeare + hs-source-dirs: app, server default-language: Haskell2010 From acf3a4de83532cb5665b39e7d0e9f79d10a7f8fd Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 5 Sep 2023 01:59:03 +0200 Subject: [PATCH 2/3] unified both servers --- server/Routes.hs | 49 ++++++++++++++++++++++----------------- server/ServerMain.hs | 27 +++++++++++++++------ workflow-visualiser.cabal | 1 + 3 files changed, 49 insertions(+), 28 deletions(-) diff --git a/server/Routes.hs b/server/Routes.hs index a4a4671..2e7fa48 100644 --- a/server/Routes.hs +++ b/server/Routes.hs @@ -15,18 +15,22 @@ import Servant.API import Servant.Server import Network.HTTP.Media ((//), (/:)) import Data.ByteString.Lazy.Internal (ByteString) +import Control.Monad.Cont (liftIO) + +import qualified Data.ByteString.Lazy.UTF8 as BSL.U directory :: FilePath directory = "." -- Directory of the static files data HTML -data HTMLTemplate +newtype HTMLTemplate = HTMLTemp ByteString -type Home = Get '[HTML] [HTMLTemplate] -- Serve app under / - :<|> "app" :> Get '[HTML] [HTMLTemplate] -- Also serve app under /app - -type RequestFile = Raw -- For serving the workflow definitions & index.json | TODO alternatively keep data after parsing & serve as '[JSON] +type Main = Get '[HTML] HTMLTemplate +type App = "app" :> Get '[HTML] HTMLTemplate +type Home = Main -- Serve app under / + :<|> App -- Also serve app under /app + :<|> Raw -- File server | TODO alternatively keep data after parsing & serve as '[JSON] instance Accept HTML where contentType _ = "text" // "html" @@ -37,27 +41,30 @@ instance MimeRender HTML ByteString where instance MimeUnrender HTML ByteString where mimeUnrender _ = Right -instance MimeRender HTML [HTMLTemplate] where - mimeRender p template = undefined --TODO use encoding function of template library +instance MimeRender HTML HTMLTemplate where + mimeRender p (HTMLTemp bs) = bs --TODO use encoding function of template library -instance MimeUnrender HTML [HTMLTemplate] where - mimeUnrender _ bs = Right undefined -- TODO use decoding function +instance MimeUnrender HTML HTMLTemplate where + mimeUnrender _ = Right . HTMLTemp -- TODO use decoding function -mainServer :: Server Home -mainServer = undefined +workFlowServer :: Server Home +workFlowServer = mainServer :<|> appServer :<|> fileServer + where + mainServer :: Server Main + mainServer = handleRequest False + appServer :: Server App + appServer = handleRequest True + fileServer :: Server Raw + fileServer = serveDirectoryFileServer directory + handleRequest :: Bool -> Handler HTMLTemplate + handleRequest appReq = do + liftIO . putStrLn $ "GET request for main application" ++ if appReq then " @/app" else "" + html <- liftIO $ BSL.U.fromString <$> readFile "editor.html" + return $ HTMLTemp html userAPI :: Proxy Home userAPI = Proxy workFlows :: Application -workFlows = serve userAPI mainServer - -fileServer :: Server RequestFile -fileServer = serveDirectoryFileServer directory - -staticAPI :: Proxy RequestFile -staticAPI = Proxy - -files :: Application -files = serve staticAPI fileServer \ No newline at end of file +workFlows = serve userAPI workFlowServer diff --git a/server/ServerMain.hs b/server/ServerMain.hs index 4e421a3..69e5954 100644 --- a/server/ServerMain.hs +++ b/server/ServerMain.hs @@ -4,16 +4,29 @@ module ServerMain where -import Routes (workFlows, files) +import Routes (workFlows) import Network.Wai import Network.Wai.Handler.Warp ( run ) import Control.Concurrent serverMain :: IO () serverMain = do - putStrLn "Starting app @ http://localhost:8081/" - mainServerThread <- forkIO $ run 8081 workFlows - putStrLn "Main server is running" - putStrLn "Starting file server @ http://localhost:8080/" - run 8080 files - + printGreeter + -- putStrLn "Starting file server @ http://localhost:8080/" + -- fileServerThread <- forkIO $ run 8080 files + -- putStrLn "File server is running\n" + putStrLn "Starting app @ http://localhost:8080/" + run 8080 workFlows + where + printGreeter = do + putStrLn "\n\n" + putStrLn " _.=:'^^':=._ " + putStrLn " +^ ^+ .__. .__. .__. .__." + putStrLn " +° (.**.) °+ | | | | | | / /" + putStrLn " °+ (.*oOOo*.) +° | | .__. | | | | / /" + putStrLn "+^ (.oO(00)Oo.) ^+ | |/ \\| | | |/ /" + putStrLn " °+ (.*oOOo*.) +° | | /\\ | | | | /" + putStrLn " +° (.**.) °+ | / \\ | | /" + putStrLn " °+_. ._+° |___/ \\___| |___/" + putStrLn " ^=`°°`=^" + putStrLn "\n\n" diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal index bbcc343..785617a 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -38,6 +38,7 @@ executable workflow-visualiser HsYAML, aeson, bytestring, + utf8-string, containers, text, vector, From 8cdca9700334b62426b5052fc25a6061d739aed4 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 5 Sep 2023 04:28:36 +0200 Subject: [PATCH 3/3] added EDE templating --- server/Routes.hs | 3 ++- server/ServerMain.hs | 12 ++++++------ server/Templates.hs | 24 ++++++++++++++++++++++++ workflow-visualiser.cabal | 6 ++++-- 4 files changed, 36 insertions(+), 9 deletions(-) create mode 100644 server/Templates.hs diff --git a/server/Routes.hs b/server/Routes.hs index 2e7fa48..1125422 100644 --- a/server/Routes.hs +++ b/server/Routes.hs @@ -18,6 +18,7 @@ import Data.ByteString.Lazy.Internal (ByteString) import Control.Monad.Cont (liftIO) import qualified Data.ByteString.Lazy.UTF8 as BSL.U +import Templates (renderAppHtml) directory :: FilePath @@ -60,7 +61,7 @@ workFlowServer = mainServer :<|> appServer :<|> fileServer handleRequest :: Bool -> Handler HTMLTemplate handleRequest appReq = do liftIO . putStrLn $ "GET request for main application" ++ if appReq then " @/app" else "" - html <- liftIO $ BSL.U.fromString <$> readFile "editor.html" + html <- liftIO $ BSL.U.fromString <$> renderAppHtml Nothing return $ HTMLTemp html userAPI :: Proxy Home diff --git a/server/ServerMain.hs b/server/ServerMain.hs index 69e5954..82b8490 100644 --- a/server/ServerMain.hs +++ b/server/ServerMain.hs @@ -15,18 +15,18 @@ serverMain = do -- putStrLn "Starting file server @ http://localhost:8080/" -- fileServerThread <- forkIO $ run 8080 files -- putStrLn "File server is running\n" - putStrLn "Starting app @ http://localhost:8080/" + putStrLn "Starting Workflow Visualiser @ http://localhost:8080/\n" run 8080 workFlows where printGreeter = do putStrLn "\n\n" putStrLn " _.=:'^^':=._ " putStrLn " +^ ^+ .__. .__. .__. .__." - putStrLn " +° (.**.) °+ | | | | | | / /" - putStrLn " °+ (.*oOOo*.) +° | | .__. | | | | / /" - putStrLn "+^ (.oO(00)Oo.) ^+ | |/ \\| | | |/ /" - putStrLn " °+ (.*oOOo*.) +° | | /\\ | | | | /" - putStrLn " +° (.**.) °+ | / \\ | | /" + putStrLn " +° (.**.) °+ |~~| |~~| |**| /::/" + putStrLn " °+ (.*oOOo*.) +° |<>| .__. |<>| |::| /**/" + putStrLn "+^ (.oO(00)Oo.) ^+ |~~|/<><>\\|~~| |**|/::/" + putStrLn " °+ (.*oOOo*.) +° |<>|~~/\\~~|<>| |::|**/" + putStrLn " +° (.**.) °+ |~~<>/ \\<>~~| |**::/" putStrLn " °+_. ._+° |___/ \\___| |___/" putStrLn " ^=`°°`=^" putStrLn "\n\n" diff --git a/server/Templates.hs b/server/Templates.hs new file mode 100644 index 0000000..c51df36 --- /dev/null +++ b/server/Templates.hs @@ -0,0 +1,24 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Templates where + +import Text.EDE +import Data.Either (fromRight) +import Data.HashMap.Strict +import Data.Aeson (Value) +import Data.Maybe (fromMaybe) +import Data.Text + + +import qualified Data.Text.Lazy as TL + +type RenderContext = HashMap Text Value + + +renderAppHtml :: Maybe RenderContext -> IO String +renderAppHtml context = do + template <- eitherParseFile "editor.html" + let result = either error id $ template >>= (`eitherRender` fromMaybe (fromPairs [] :: RenderContext) context) + return $ TL.unpack result diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal index 785617a..04a724e 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -30,7 +30,8 @@ executable workflow-visualiser Index, YamlParser, ServerMain, - Routes + Routes, + Templates -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -40,6 +41,7 @@ executable workflow-visualiser bytestring, utf8-string, containers, + unordered-containers, text, vector, directory, @@ -50,6 +52,6 @@ executable workflow-visualiser wai, warp, http-media, - shakespeare + ede hs-source-dirs: app, server default-language: Haskell2010