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..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 ad349d9..04a724e 100644 --- a/workflow-visualiser.cabal +++ b/workflow-visualiser.cabal @@ -28,7 +28,10 @@ executable workflow-visualiser other-modules: Workflow, Export, Index, - YamlParser + YamlParser, + ServerMain, + Routes, + Templates -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -36,11 +39,19 @@ executable workflow-visualiser HsYAML, aeson, bytestring, + utf8-string, containers, + unordered-containers, text, vector, directory, regex-tdfa, - mtl - hs-source-dirs: app + mtl, + servant, + servant-server, + wai, + warp, + http-media, + ede + hs-source-dirs: app, server default-language: Haskell2010