Skip to content

Commit 9dad6e6

Browse files
soficshiftLucas V. Rsrid
authored
Live server shim/websocket customization (#152)
* Server customization Allows Ema users to specify the Ema Shim or a custom websocket response. This can be used, for instance, to make the server open files in the user's favorite editor in response to a websocket request. * Add Ex06_Markdown * Favour Data.Default, instead of writing default* functions. * Add SiteConfig, avoiding extra run* functions --------- Co-authored-by: Lucas V. R <[email protected]> Co-authored-by: Sridhar Ratnakumar <[email protected]>
1 parent 8a9e465 commit 9dad6e6

File tree

8 files changed

+319
-71
lines changed

8 files changed

+319
-71
lines changed

‎ema-examples/ema-examples.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -126,6 +126,7 @@ library
126126
Ema.Example.Ex03_Store
127127
Ema.Example.Ex04_Multi
128128
Ema.Example.Ex05_MultiRoute
129+
Ema.Example.Ex06_Markdown
129130

130131
hs-source-dirs: src
131132
default-language: Haskell2010

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

Lines changed: 158 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,158 @@
1+
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE QuasiQuotes #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
{-# LANGUAGE UndecidableInstances #-}
5+
6+
{- | A very simple markdown website using Ema.Route.Lib.Extra.PandocRoute.
7+
8+
Also demostrates how to set up a custom server for following the currently open
9+
note, using a websocket for editor integration.
10+
-}
11+
module Ema.Example.Ex06_Markdown where
12+
13+
import Control.Monad.Logger (LogLevel (..), MonadLoggerIO (..), defaultLoc, logInfoNS)
14+
import Control.Monad.Logger.Extras (runLoggerLoggingT)
15+
import Data.Default (Default (..))
16+
import Data.Dependent.Sum (DSum (..))
17+
import Data.Generics.Sum.Any
18+
import Data.Map (member)
19+
import Ema
20+
import Ema.CLI qualified as CLI
21+
import Ema.Route.Generic.TH
22+
import Ema.Route.Lib.Extra.PandocRoute qualified as Pandoc
23+
import Ema.Server (EmaServerOptions (..), EmaWsHandler (..), wsClientJS)
24+
import Network.WebSockets qualified as WS
25+
import Optics.Core ((%))
26+
import System.Directory (makeAbsolute)
27+
import System.FilePath (isAbsolute, isRelative, makeRelative)
28+
import Text.Blaze.Html.Renderer.Utf8 qualified as RU
29+
import Text.Blaze.Html5 ((!))
30+
import Text.Blaze.Html5 qualified as H
31+
import Text.Blaze.Html5.Attributes qualified as A
32+
import UnliftIO.Async (race)
33+
import UnliftIO.STM (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan)
34+
35+
data Arg = Arg
36+
{ pandocArg :: Pandoc.Arg
37+
, editorWsAddress :: String
38+
, editorWsPort :: Int
39+
}
40+
deriving stock (Generic)
41+
42+
instance Default Arg where
43+
def =
44+
Arg
45+
{ pandocArg =
46+
def
47+
{ Pandoc.argBaseDir = "src/Ema/Example/Ex06_Markdown"
48+
}
49+
, editorWsAddress = "127.0.0.1"
50+
, editorWsPort = 9160
51+
}
52+
53+
data Model = Model
54+
{ pandocModel :: Pandoc.Model
55+
, wsNextRoute :: TChan Route
56+
}
57+
deriving stock (Generic)
58+
59+
newtype Route = Route Pandoc.PandocRoute
60+
deriving stock (Show, Eq, Ord, Generic)
61+
62+
deriveGeneric ''Route
63+
deriveIsRoute
64+
''Route
65+
[t|
66+
'[ WithModel Model
67+
, WithSubRoutes
68+
'[ Pandoc.PandocRoute
69+
]
70+
]
71+
|]
72+
73+
instance EmaSite Route where
74+
type SiteArg Route = Arg
75+
76+
siteInput act arg = do
77+
pandocDyn <- siteInput @Pandoc.PandocRoute act (pandocArg arg)
78+
editorWsDyn <- wsConnDyn arg
79+
return $ Model <$> pandocDyn <*> editorWsDyn
80+
81+
siteOutput rp m (Route r) = do
82+
(pandoc, write) <- siteOutput (rp % _As @"Route") (pandocModel m) r
83+
let head' = H.title "Basic site" >> H.base ! A.href "/"
84+
body :: Text = coerce $ write pandoc
85+
html = RU.renderHtml do
86+
H.docType
87+
H.html ! A.lang "en" $ do
88+
H.head do
89+
H.meta ! A.charset "UTF-8"
90+
H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
91+
head'
92+
H.body $ H.preEscapedToHtml body
93+
return $ AssetGenerated Html html
94+
95+
wsConnDyn :: forall m. (MonadLoggerIO m) => Arg -> m (Dynamic m (TChan Route))
96+
wsConnDyn arg = do
97+
value <- newBroadcastTChanIO
98+
let manage :: m ()
99+
manage = do
100+
logger <- askLoggerIO
101+
let log = logger defaultLoc "wsConnDyn" LevelInfo
102+
liftIO $ WS.runServer (editorWsAddress arg) (editorWsPort arg) \pendingConn -> do
103+
conn :: WS.Connection <- WS.acceptRequest pendingConn
104+
log "websocket connected"
105+
WS.withPingThread conn 30 pass $
106+
void $
107+
infinitely do
108+
msg <- liftIO $ toString @Text <$> WS.receiveData conn
109+
log $ "got message: " <> show msg
110+
baseDir <- makeAbsolute (Pandoc.argBaseDir $ pandocArg arg)
111+
let fp = makeRelative baseDir msg
112+
case Pandoc.mkPandocRoute fp of
113+
Just (_, route)
114+
-- We should have received an absolute file path inside the base dir
115+
| isAbsolute msg && isRelative fp ->
116+
atomically $ writeTChan value (Route route)
117+
_ -> pass
118+
return $ Dynamic (value, const manage)
119+
120+
main :: IO ()
121+
main = runWithFollow def
122+
123+
runWithFollow ::
124+
SiteArg Route ->
125+
IO ()
126+
runWithFollow input = do
127+
cli <- CLI.cliAction
128+
let cfg = SiteConfig cli followServerOptions
129+
result <- snd <$> runSiteWith @Route cfg input
130+
case result of
131+
CLI.Run _ :=> Identity () ->
132+
flip runLoggerLoggingT (CLI.getLogger cli) $
133+
CLI.crash "ema" "Live server unexpectedly stopped"
134+
CLI.Generate _ :=> Identity _ -> pass
135+
136+
followServerOptions :: EmaServerOptions Route
137+
followServerOptions = EmaServerOptions wsClientJS followServerHandler
138+
139+
followServerHandler :: EmaWsHandler Route
140+
followServerHandler = EmaWsHandler handle
141+
where
142+
defaultHandler = unEmaWsHandler $ def @(EmaWsHandler ())
143+
handle conn model = do
144+
either id id <$> race (defaultHandler conn ()) followHandler
145+
where
146+
rp = fromPrism_ $ routePrism model
147+
log = logInfoNS "followServerHandler"
148+
followHandler = do
149+
listenerChan <- atomically $ dupTChan $ wsNextRoute model
150+
route <- atomically $ readTChan listenerChan
151+
let Route pRoute = route
152+
path = routeUrl rp route
153+
if pRoute `member` Pandoc.modelPandocs (pandocModel model)
154+
then do
155+
log $ "switching to " <> show pRoute
156+
liftIO $ WS.sendTextData conn $ "SWITCH " <> path
157+
else log $ "invalid route " <> show pRoute
158+
followHandler

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
# This is index
2+
3+
- [go to test](test)

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

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
;;; -*- lexical-binding: t; -*-
2+
;;;
3+
;;; Example "open in ema" command for Ex06_Markdown
4+
5+
(defvar ema-ws-address "ws://127.0.0.1:9160")
6+
7+
(defvar ema-ws--conn nil)
8+
9+
(defun ema-ws-connect ()
10+
(interactive)
11+
(require 'websocket)
12+
(unless ema-ws--conn
13+
(websocket-open
14+
ema-ws-address
15+
:on-open (lambda (ws) (message "ema ws: connected") (setq ema-ws--conn ws))
16+
:on-close (lambda (_) (message "ema ws: disconnected") (setq ema-ws--conn nil)))))
17+
18+
(defun ema-ws-disconnect ()
19+
(interactive)
20+
(require 'websocket)
21+
(when ema-ws--conn (websocket-close ema-ws--conn)))
22+
23+
(defun open-in-ema ()
24+
(interactive)
25+
(ema-ws-connect)
26+
(when ema-ws--conn
27+
(when-let ((fp (buffer-file-name)))
28+
(websocket-send-text ema-ws--conn fp))))

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
# This is test
2+
3+
- [go to index](index)

‎ema/src/Ema/App.hs

Lines changed: 27 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,17 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22

33
module Ema.App (
4+
SiteConfig (..),
45
runSite,
56
runSite_,
6-
runSiteWithCli,
7+
runSiteWith,
78
) where
89

910
import Control.Concurrent (threadDelay)
1011
import Control.Concurrent.Async (race_)
1112
import Control.Monad.Logger (LoggingT (runLoggingT), MonadLoggerIO (askLoggerIO), logInfoNS, logWarnNS)
1213
import Control.Monad.Logger.Extras (runLoggerLoggingT)
14+
import Data.Default (Default, def)
1315
import Data.Dependent.Sum (DSum ((:=>)))
1416
import Data.LVar qualified as LVar
1517
import Data.Some (Some (Some))
@@ -22,6 +24,18 @@ import Ema.Server qualified as Server
2224
import Ema.Site (EmaSite (SiteArg, siteInput), EmaStaticSite)
2325
import System.Directory (getCurrentDirectory)
2426

27+
data SiteConfig r = SiteConfig
28+
{ siteConfigCli :: CLI.Cli
29+
, siteConfigServerOpts :: Server.EmaServerOptions r
30+
}
31+
32+
instance Default (SiteConfig r) where
33+
def =
34+
SiteConfig
35+
{ siteConfigCli = def
36+
, siteConfigServerOpts = def
37+
}
38+
2539
{- | Run the given Ema site,
2640
2741
Takes as argument the associated `SiteArg`.
@@ -37,7 +51,8 @@ runSite ::
3751
IO [FilePath]
3852
runSite input = do
3953
cli <- CLI.cliAction
40-
result <- snd <$> runSiteWithCli @r cli input
54+
let cfg = SiteConfig cli def
55+
result <- snd <$> runSiteWith @r cfg input
4156
case result of
4257
CLI.Run _ :=> Identity () ->
4358
flip runLoggerLoggingT (getLogger cli) $
@@ -49,23 +64,26 @@ runSite input = do
4964
runSite_ :: forall r. (Show r, Eq r, EmaStaticSite r) => SiteArg r -> IO ()
5065
runSite_ = void . runSite @r
5166

52-
{- | Like @runSite@ but takes the CLI action. Also returns more information.
67+
{- | Like @runSite@ but takes custom @SiteConfig@.
5368
54-
Useful if you are handling the CLI arguments yourself.
69+
Useful if you are handling the CLI arguments yourself and/or customizing the
70+
server websocket handler.
5571
56-
Use "void $ Ema.runSiteWithCli def ..." if you are running live-server only.
72+
Use "void $ Ema.runSiteWith def ..." if you are running live-server only.
5773
-}
58-
runSiteWithCli ::
74+
runSiteWith ::
5975
forall r.
6076
(Show r, Eq r, EmaStaticSite r) =>
61-
CLI.Cli ->
77+
SiteConfig r ->
6278
SiteArg r ->
6379
IO
6480
( -- The initial model value.
6581
RouteModel r
6682
, DSum CLI.Action Identity
6783
)
68-
runSiteWithCli cli siteArg = do
84+
runSiteWith cfg siteArg = do
85+
let opts = siteConfigServerOpts cfg
86+
cli = siteConfigCli cfg
6987
flip runLoggerLoggingT (getLogger cli) $ do
7088
cwd <- liftIO getCurrentDirectory
7189
logInfoNS "ema" $ "Launching Ema under: " <> toText cwd
@@ -88,6 +106,6 @@ runSiteWithCli cli siteArg = do
88106
liftIO $ threadDelay maxBound
89107
)
90108
( flip runLoggingT logger $ do
91-
Server.runServerWithWebSocketHotReload @r host mport model
109+
Server.runServerWithWebSocketHotReload @r opts host mport model
92110
)
93111
pure (model0, act :=> Identity ())

0 commit comments

Comments
 (0)