Merge branch 'main' into stages-dsl

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

dsl/dsl.cabal.license

@@ -1,2 +0,0 @@
-SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
-SPDX-License-Identifier: AGPL-3.0-or-later

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

@@ -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