Live server shim/websocket customization

ema-examples/ema-examples.cabal

@@ -126,6 +126,7 @@ library
     Ema.Example.Ex03_Store
     Ema.Example.Ex04_Multi
     Ema.Example.Ex05_MultiRoute
+    Ema.Example.Ex06_Markdown
 
   hs-source-dirs:   src
   default-language: Haskell2010

ema-examples/src/Ema/Example/Ex06_Markdown.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{- | A very simple markdown website using Ema.Route.Lib.Extra.PandocRoute.
+
+ Also demostrates how to set up a custom server for following the currently open
+ note, using a websocket for editor integration.
+-}
+module Ema.Example.Ex06_Markdown where
+
+import Control.Monad.Logger (LogLevel (..), MonadLoggerIO (..), defaultLoc, logInfoNS)
+import Control.Monad.Logger.Extras (runLoggerLoggingT)
+import Data.Default (Default (..))
+import Data.Dependent.Sum (DSum (..))
+import Data.Generics.Sum.Any
+import Data.Map (member)
+import Ema
+import Ema.CLI qualified as CLI
+import Ema.Route.Generic.TH
+import Ema.Route.Lib.Extra.PandocRoute qualified as Pandoc
+import Ema.Server (EmaServerOptions (..), EmaWsHandler (..), wsClientJS)
+import Network.WebSockets qualified as WS
+import Optics.Core ((%))
+import System.Directory (makeAbsolute)
+import System.FilePath (isAbsolute, isRelative, makeRelative)
+import Text.Blaze.Html.Renderer.Utf8 qualified as RU
+import Text.Blaze.Html5 ((!))
+import Text.Blaze.Html5 qualified as H
+import Text.Blaze.Html5.Attributes qualified as A
+import UnliftIO.Async (race)
+import UnliftIO.STM (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan)
+
+data Arg = Arg
+  { pandocArg :: Pandoc.Arg
+  , editorWsAddress :: String
+  , editorWsPort :: Int
+  }
+  deriving stock (Generic)
+
+instance Default Arg where
+  def =
+    Arg
+      { pandocArg =
+          def
+            { Pandoc.argBaseDir = "src/Ema/Example/Ex06_Markdown"
+            }
+      , editorWsAddress = "127.0.0.1"
+      , editorWsPort = 9160
+      }
+
+data Model = Model
+  { pandocModel :: Pandoc.Model
+  , wsNextRoute :: TChan Route
+  }
+  deriving stock (Generic)
+
+newtype Route = Route Pandoc.PandocRoute
+  deriving stock (Show, Eq, Ord, Generic)
+
+deriveGeneric ''Route
+deriveIsRoute
+  ''Route
+  [t|
+    '[ WithModel Model
+     , WithSubRoutes
+        '[ Pandoc.PandocRoute
+         ]
+     ]
+    |]
+
+instance EmaSite Route where
+  type SiteArg Route = Arg
+
+  siteInput act arg = do
+    pandocDyn <- siteInput @Pandoc.PandocRoute act (pandocArg arg)
+    editorWsDyn <- wsConnDyn arg
+    return $ Model <$> pandocDyn <*> editorWsDyn
+
+  siteOutput rp m (Route r) = do
+    (pandoc, write) <- siteOutput (rp % _As @"Route") (pandocModel m) r
+    let head' = H.title "Basic site" >> H.base ! A.href "/"
+        body :: Text = coerce $ write pandoc
+        html = RU.renderHtml do
+          H.docType
+          H.html ! A.lang "en" $ do
+            H.head do
+              H.meta ! A.charset "UTF-8"
+              H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
+              head'
+            H.body $ H.preEscapedToHtml body
+    return $ AssetGenerated Html html
+
+wsConnDyn :: forall m. (MonadLoggerIO m) => Arg -> m (Dynamic m (TChan Route))
+wsConnDyn arg = do
+  value <- newBroadcastTChanIO
+  let manage :: m ()
+      manage = do
+        logger <- askLoggerIO
+        let log = logger defaultLoc "wsConnDyn" LevelInfo
+        liftIO $ WS.runServer (editorWsAddress arg) (editorWsPort arg) \pendingConn -> do
+          conn :: WS.Connection <- WS.acceptRequest pendingConn
+          log "websocket connected"
+          WS.withPingThread conn 30 pass $
+            void $
+              infinitely do
+                msg <- liftIO $ toString @Text <$> WS.receiveData conn
+                log $ "got message: " <> show msg
+                baseDir <- makeAbsolute (Pandoc.argBaseDir $ pandocArg arg)
+                let fp = makeRelative baseDir msg
+                case Pandoc.mkPandocRoute fp of
+                  Just (_, route)
+                    -- We should have received an absolute file path inside the base dir
+                    | isAbsolute msg && isRelative fp ->
+                        atomically $ writeTChan value (Route route)
+                  _ -> pass
+  return $ Dynamic (value, const manage)
+
+main :: IO ()
+main = runWithFollow def
+
+runWithFollow ::
+  SiteArg Route ->
+  IO ()
+runWithFollow input = do
+  cli <- CLI.cliAction
+  let cfg = SiteConfig cli followServerOptions
+  result <- snd <$> runSiteWith @Route cfg input
+  case result of
+    CLI.Run _ :=> Identity () ->
+      flip runLoggerLoggingT (CLI.getLogger cli) $
+        CLI.crash "ema" "Live server unexpectedly stopped"
+    CLI.Generate _ :=> Identity _ -> pass
+
+followServerOptions :: EmaServerOptions Route
+followServerOptions = EmaServerOptions wsClientJS followServerHandler
+
+followServerHandler :: EmaWsHandler Route
+followServerHandler = EmaWsHandler handle
+  where
+    defaultHandler = unEmaWsHandler $ def @(EmaWsHandler ())
+    handle conn model = do
+      either id id <$> race (defaultHandler conn ()) followHandler
+      where
+        rp = fromPrism_ $ routePrism model
+        log = logInfoNS "followServerHandler"
+        followHandler = do
+          listenerChan <- atomically $ dupTChan $ wsNextRoute model
+          route <- atomically $ readTChan listenerChan
+          let Route pRoute = route
+              path = routeUrl rp route
+          if pRoute `member` Pandoc.modelPandocs (pandocModel model)
+            then do
+              log $ "switching to " <> show pRoute
+              liftIO $ WS.sendTextData conn $ "SWITCH " <> path
+            else log $ "invalid route " <> show pRoute
+          followHandler

ema-examples/src/Ema/Example/Ex06_Markdown/index.md

@@ -0,0 +1,3 @@
+# This is index
+
+- [go to test](test)

ema-examples/src/Ema/Example/Ex06_Markdown/integration-example.el

@@ -0,0 +1,28 @@
+;;; -*- lexical-binding: t; -*-
+;;;
+;;; Example "open in ema" command for Ex06_Markdown
+
+(defvar ema-ws-address "ws://127.0.0.1:9160")
+
+(defvar ema-ws--conn nil)
+
+(defun ema-ws-connect ()
+  (interactive)
+  (require 'websocket)
+  (unless ema-ws--conn
+    (websocket-open
+     ema-ws-address
+     :on-open (lambda (ws) (message "ema ws: connected") (setq ema-ws--conn ws))
+     :on-close (lambda (_) (message "ema ws: disconnected") (setq ema-ws--conn nil)))))
+
+(defun ema-ws-disconnect ()
+  (interactive)
+  (require 'websocket)
+  (when ema-ws--conn (websocket-close ema-ws--conn)))
+
+(defun open-in-ema ()
+  (interactive)
+  (ema-ws-connect)
+  (when ema-ws--conn
+    (when-let ((fp (buffer-file-name)))
+      (websocket-send-text ema-ws--conn fp))))

ema-examples/src/Ema/Example/Ex06_Markdown/test.md

@@ -0,0 +1,3 @@
+# This is test
+
+- [go to index](index)

ema/src/Ema/App.hs

@@ -1,15 +1,17 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Ema.App (
+  SiteConfig (..),
   runSite,
   runSite_,
-  runSiteWithCli,
+  runSiteWith,
 ) where
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
 import Control.Monad.Logger (LoggingT (runLoggingT), MonadLoggerIO (askLoggerIO), logInfoNS, logWarnNS)
 import Control.Monad.Logger.Extras (runLoggerLoggingT)
+import Data.Default (Default, def)
 import Data.Dependent.Sum (DSum ((:=>)))
 import Data.LVar qualified as LVar
 import Data.Some (Some (Some))
@@ -22,6 +24,18 @@ import Ema.Server qualified as Server
 import Ema.Site (EmaSite (SiteArg, siteInput), EmaStaticSite)
 import System.Directory (getCurrentDirectory)
 
+data SiteConfig r = SiteConfig
+  { siteConfigCli :: CLI.Cli
+  , siteConfigServerOpts :: Server.EmaServerOptions r
+  }
+
+instance Default (SiteConfig r) where
+  def =
+    SiteConfig
+      { siteConfigCli = def
+      , siteConfigServerOpts = def
+      }
+
 {- | Run the given Ema site,
 
   Takes as argument the associated `SiteArg`.
@@ -37,7 +51,8 @@ runSite ::
   IO [FilePath]
 runSite input = do
   cli <- CLI.cliAction
-  result <- snd <$> runSiteWithCli @r cli input
+  let cfg = SiteConfig cli def
+  result <- snd <$> runSiteWith @r cfg input
   case result of
     CLI.Run _ :=> Identity () ->
       flip runLoggerLoggingT (getLogger cli) $
@@ -49,23 +64,26 @@ runSite input = do
 runSite_ :: forall r. (Show r, Eq r, EmaStaticSite r) => SiteArg r -> IO ()
 runSite_ = void . runSite @r
 
-{- | Like @runSite@ but takes the CLI action. Also returns more information.
+{- | Like @runSite@ but takes custom @SiteConfig@.
 
- Useful if you are handling the CLI arguments yourself.
+ Useful if you are handling the CLI arguments yourself and/or customizing the
+ server websocket handler.
 
- Use "void $ Ema.runSiteWithCli def ..." if you are running live-server only.
+ Use "void $ Ema.runSiteWith def ..." if you are running live-server only.
 -}
-runSiteWithCli ::
+runSiteWith ::
   forall r.
   (Show r, Eq r, EmaStaticSite r) =>
-  CLI.Cli ->
+  SiteConfig r ->
   SiteArg r ->
   IO
     ( -- The initial model value.
       RouteModel r
     , DSum CLI.Action Identity
     )
-runSiteWithCli cli siteArg = do
+runSiteWith cfg siteArg = do
+  let opts = siteConfigServerOpts cfg
+      cli = siteConfigCli cfg
   flip runLoggerLoggingT (getLogger cli) $ do
     cwd <- liftIO getCurrentDirectory
     logInfoNS "ema" $ "Launching Ema under: " <> toText cwd
@@ -88,6 +106,6 @@ runSiteWithCli cli siteArg = do
                 liftIO $ threadDelay maxBound
             )
             ( flip runLoggingT logger $ do
-                Server.runServerWithWebSocketHotReload @r host mport model
+                Server.runServerWithWebSocketHotReload @r opts host mport model
             )
         pure (model0, act :=> Identity ())