2 files changed, 55 insertions, 0 deletions
diff --git a/main/Main.hs b/main/Main.hs
index 3f78db1..a1a8b50 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -61,6 +61,7 @@ import State
 import Terminal
 import Test
 import Version
+import WebSocket
 
 data Options = Options
     { optServer :: ServerOptions
@@ -68,6 +69,7 @@ data Options = Options
     , optStorage :: StorageOption
     , optChatroomAutoSubscribe :: Maybe Int
     , optDmBotEcho :: Maybe Text
+    , optWebSocketServer :: Maybe Int
     , optShowHelp :: Bool
     , optShowVersion :: Bool
     }
@@ -90,6 +92,7 @@ defaultOptions = Options
     , optStorage = DefaultStorage
     , optChatroomAutoSubscribe = Nothing
     , optDmBotEcho = Nothing
+    , optWebSocketServer = Nothing
     , optShowHelp = False
     , optShowVersion = False
     }
@@ -144,6 +147,9 @@ options =
     , Option [] ["dm-bot-echo"]
         (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
         "automatically reply to direct messages with the same text prefixed with <prefix>"
+    , Option [] [ "websocket-server" ]
+        (ReqArg (\value -> \opts -> opts { optWebSocketServer = Just (read value) }) "<port>")
+        "start WebSocket server on given port"
     , Option ['h'] ["help"]
         (NoArg $ \opts -> opts { optShowHelp = True })
         "show this help and exit"
@@ -362,6 +368,10 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
         startServer (optServer opts) erebosHead extPrintLn $
             map soptService $ filter soptEnabled $ optServices opts
 
+    case optWebSocketServer opts of
+        Just port -> startWebsocketServer server "::" port extPrintLn
+        Nothing -> return ()
+
     void $ liftIO $ forkIO $ void $ forever $ do
         peer <- getNextPeerChange server
         peerIdentity peer >>= \case
diff --git a/main/WebSocket.hs b/main/WebSocket.hs
new file mode 100644
index 0000000..fbdd65f
--- /dev/null
+++ b/main/WebSocket.hs
@@ -0,0 +1,45 @@
+module WebSocket (
+    startWebsocketServer,
+) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import Data.ByteString.Lazy qualified as BL
+import Data.Unique
+
+import Erebos.Network
+
+import Network.WebSockets qualified as WS
+
+
+data WebSocketAddress = WebSocketAddress Unique WS.Connection
+
+instance Eq WebSocketAddress where
+    WebSocketAddress u _ == WebSocketAddress u' _ = u == u'
+
+instance Ord WebSocketAddress where
+    compare (WebSocketAddress u _) (WebSocketAddress u' _) = compare u u'
+
+instance Show WebSocketAddress where
+    show (WebSocketAddress _ _) = "websocket"
+
+instance PeerAddressType WebSocketAddress where
+  sendBytesToAddress (WebSocketAddress _ conn) msg = do
+      WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg
+
+startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO ()
+startWebsocketServer server addr port logd = do
+    void $ forkIO $ do
+        WS.runServer addr port $ \pending -> do
+            conn <- WS.acceptRequest pending
+            u <- newUnique
+            let paddr = WebSocketAddress u conn
+            void $ serverPeerCustom server paddr
+            handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do
+                WS.withPingThread conn 30 (return ()) $ do
+                    forever $ do
+                        WS.receiveDataMessage conn >>= \case
+                            WS.Binary msg -> receivedFromCustomAddress server paddr $ BL.toStrict msg
+                            WS.Text {} -> logd $ "unexpected websocket text message"