.gitignore

@@ -3,6 +3,7 @@
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
 /dist-newstyle
+/dsl/dist-newstyle
 .stack-work
 CHANGELOG.md
 test.json

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

server/Routes.hs

@@ -0,0 +1,71 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- 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

server/ServerMain.hs

@@ -0,0 +1,32 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- 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"

server/Templates.hs

@@ -0,0 +1,24 @@
+-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
+--
+-- 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

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