diff --git a/app/Main.hs b/app/Main.hs index 0fec81a..b330b6f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,6 +34,7 @@ module Main where import Data.Text.Lazy (toStrict) import Debug.Trace (trace) import DSLMain (dslMain) + import ServerMain (serverMain) --------------------------------------- @@ -47,6 +48,7 @@ module Main where main = getArgs >>= process >>= finish where process :: [String] -> IO Bool process ["--dsl"] = dslMain >> return True + 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/dsl/app/DSL.hs b/dsl/DSL.hs similarity index 100% rename from dsl/app/DSL.hs rename to dsl/DSL.hs diff --git a/dsl/app/DSLMain.hs b/dsl/DSLMain.hs similarity index 100% rename from dsl/app/DSLMain.hs rename to dsl/DSLMain.hs diff --git a/dsl/app/Transpiler.hs b/dsl/Transpiler.hs similarity index 100% rename from dsl/app/Transpiler.hs rename to dsl/Transpiler.hs diff --git a/dsl/dsl.cabal.license b/dsl/dsl.cabal.license deleted file mode 100644 index b1bfe50..0000000 --- a/dsl/dsl.cabal.license +++ /dev/null @@ -1,2 +0,0 @@ -SPDX-FileCopyrightText: 2023 David Mosbach -SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/server/Routes.hs b/server/Routes.hs new file mode 100644 index 0000000..1125422 --- /dev/null +++ b/server/Routes.hs @@ -0,0 +1,71 @@ +-- 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) +import Control.Monad.Cont (liftIO) + +import qualified Data.ByteString.Lazy.UTF8 as BSL.U +import Templates (renderAppHtml) + + +directory :: FilePath +directory = "." -- Directory of the static files + +data HTML +newtype HTMLTemplate = HTMLTemp ByteString + +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" + +instance MimeRender HTML ByteString where + mimeRender _ bs = bs + +instance MimeUnrender HTML ByteString where + mimeUnrender _ = Right + +instance MimeRender HTML HTMLTemplate where + mimeRender p (HTMLTemp bs) = bs --TODO use encoding function of template library + +instance MimeUnrender HTML HTMLTemplate where + mimeUnrender _ = Right . HTMLTemp -- TODO use decoding function + + +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 <$> renderAppHtml Nothing + return $ HTMLTemp html + +userAPI :: Proxy Home +userAPI = Proxy + +workFlows :: Application +workFlows = serve userAPI workFlowServer diff --git a/server/ServerMain.hs b/server/ServerMain.hs new file mode 100644 index 0000000..82b8490 --- /dev/null +++ b/server/ServerMain.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2023 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module ServerMain where + +import Routes (workFlows) +import Network.Wai +import Network.Wai.Handler.Warp ( run ) +import Control.Concurrent + +serverMain :: IO () +serverMain = do + printGreeter + -- putStrLn "Starting file server @ http://localhost:8080/" + -- fileServerThread <- forkIO $ run 8080 files + -- putStrLn "File server is running\n" + 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 " ^=`°°`=^" + 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 692ffd1..179c64a 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -32,6 +32,9 @@ executable workflow-visualiser DSLMain, DSL, Transpiler + ServerMain, + Routes, + Templates -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -39,13 +42,20 @@ executable workflow-visualiser HsYAML, aeson, bytestring, + utf8-string, containers, + unordered-containers, text, vector, directory, regex-tdfa, mtl, parsec, - utf8-string - hs-source-dirs: app, dsl/app + servant, + servant-server, + wai, + warp, + http-media, + ede + hs-source-dirs: app, server, dsl default-language: Haskell2010