Add Ex06_Markdown

Author: Lucas V. R

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,153 @@
+{-# 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, defaultEmaWsHandler, 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
+  result <- snd <$> runSiteWithServerOpts @Route followServerOptions cli 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 conn model =
+  either id id <$> race (defaultEmaWsHandler @() 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/www/ema-shim.js

@@ -156,6 +156,9 @@ function init(reconnecting) {
         if (evt.data.startsWith("REDIRECT ")) {
             console.log("ema: redirect");
             document.location.href = evt.data.slice("REDIRECT ".length);
+        } else if (evt.data.startsWith("SWITCH ")) {
+            console.log("ema: switch");
+            switchRoute(evt.data.slice("SWITCH ".length));
         } else {
             console.log("ema: ✍ Patching DOM");
             setHtml(document.documentElement, evt.data);