diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
# Changelog
-# 2019-07-14
+# v0.0.2 (2019-07-16)
+
+* Rename `broadcast` -> `send`
+* Better module layout
+* Server the index.html page over HTTP
+
+# v0.0.1 (2019-07-14)
* Initial release
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -6,15 +6,15 @@
## Contents
-The `Ghci.Websockets` module implements the actual websocket server, broadcasting JSON objects to all clients. `Ghci.Websockets.Simple` adds a custom message type for text, HTML, and plots on top of that.
+The `Ghci.Server.Websockets` module implements the actual websocket server, sending JSON objects to all clients. `Ghci.Server.Http` servers the index.html page that goes with the messages defined in `Ghci.Websockets.Message`.
## Quickstart
* Add `ghci-websockets` to the `build-depends` field of your .cabal file
* Run `cabal new-repl`
-* Run `Ghci.Websockets.Simple.initialiseDef`
-* Open `html/index.html` in a browser
-* In GHCi, run `Ghci.Websockets.Simple.broadcastText "hello"` (see also `broadcastHtml` and `broadcastPlot` from the same module). You may need `:set -XOverloadedStrings`.
+* Run `Ghci.Server.start`
+* Open `localhost:3000` in a browser
+* In GHCi, run `Ghci.Server.sendText "hello"` (see also `sendHtml` and `sendPlot` from the same module). You may need `:set -XOverloadedStrings`.
## Warning
diff --git a/ghci-websockets.cabal b/ghci-websockets.cabal
--- a/ghci-websockets.cabal
+++ b/ghci-websockets.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.2
name: ghci-websockets
-version: 0.0.1
+version: 0.0.2
license: BSD-3-Clause
license-file: LICENSE
copyright: Copyright (C) 2019 Jann Mueller
@@ -26,8 +26,12 @@
library
exposed-modules:
- Ghci.Websockets
- Ghci.Websockets.Simple
+ Ghci.Server.Http.Internal
+ Ghci.Server.Http.Stage0
+ Ghci.Server.Websockets.Internal
+ Ghci.Server.Websockets.Message
+ Ghci.Server.Config
+ Ghci.Server
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
@@ -37,6 +41,8 @@
foreign-store -any,
websockets -any,
text -any,
- containers -any
-
-
+ containers -any,
+ wai-app-static -any,
+ bytestring -any,
+ wai -any,
+ warp -any
diff --git a/ghci-websockets.gif b/ghci-websockets.gif
Binary files a/ghci-websockets.gif and b/ghci-websockets.gif differ
diff --git a/src/Ghci/Server.hs b/src/Ghci/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server.hs
@@ -0,0 +1,40 @@
+module Ghci.Server(
+ -- $docs
+ -- * Starting the server
+ start
+ , startConfig
+ -- * Sending messages
+ , sendText
+ , sendHtml
+ , sendPlot
+ -- * Configuration
+ , Config
+ , Verbosity(..)
+ , defaultConfig
+ , cfHTTPPort
+ , cfVerbosity
+ , cfWSPort
+ ) where
+
+import Ghci.Server.Config (Config, Verbosity (..),
+ cfHTTPPort, cfVerbosity,
+ cfWSPort, defaultConfig)
+import qualified Ghci.Server.Http.Internal as HTTP
+import qualified Ghci.Server.Websockets.Internal as WS
+import Ghci.Server.Websockets.Message (sendHtml, sendPlot,
+ sendText)
+
+-- $docs
+-- This modules implements a websocket server whose state survives GHCi
+-- reloads. To use it, run 'start' once per GHCi session, and then
+-- use 'sendText', 'sendHtml' and 'sendPlot' to show the
+-- values on all clients that are currently connected.
+
+-- | Start the websocket and HTTP servers using the config
+startConfig :: Config -> IO ()
+startConfig = (<>) <$> HTTP.startConfig <*> WS.startConfig
+
+-- | Start the server with default settings (HTTP on port 3000, websockets
+-- on port 9160)
+start :: IO ()
+start = startConfig defaultConfig
diff --git a/src/Ghci/Server/Config.hs b/src/Ghci/Server/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server/Config.hs
@@ -0,0 +1,34 @@
+module Ghci.Server.Config(
+ Config
+ , defaultConfig
+ , cfWSPort
+ , cfHTTPPort
+ , cfVerbosity
+ , Verbosity(..)
+ , logStr
+ ) where
+
+-- | What to do with log messages
+data Verbosity =
+ Verbose -- ^ Write all log messages to stdout
+ | Silent -- ^ Ignore all log messages
+ deriving (Eq, Ord, Show)
+
+-- | Server configuration
+data Config =
+ Config
+ { cfWSPort :: Int -- ^ Websocket port
+ , cfHTTPPort :: Int -- ^ HTTP port
+ , cfVerbosity :: Verbosity -- ^ What to do with log messages
+ }
+
+-- | Log a message according to the configured 'Verbosity'
+logStr :: Config -> String -> IO ()
+logStr c s = case cfVerbosity c of
+ Silent -> pure ()
+ Verbose -> putStrLn s
+
+-- | Default config, use ports 9160 (websockets) and 3000 (http) and ignore all
+-- log messages.
+defaultConfig :: Config
+defaultConfig = Config 9160 3000 Silent
diff --git a/src/Ghci/Server/Http/Internal.hs b/src/Ghci/Server/Http/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server/Http/Internal.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | A simple HTTP server that serves the index.html page
+module Ghci.Server.Http.Internal where
+
+import Control.Concurrent (forkIO)
+import Control.Monad (void)
+import Ghci.Server.Http.Stage0 (mkEmbedded)
+import Network.Wai (Application)
+import Network.Wai.Application.Static (ssIndices, ssRedirectToIndex,
+ staticApp)
+import Network.Wai.Handler.Warp (run)
+import WaiAppStatic.Storage.Embedded
+import WaiAppStatic.Types (unsafeToPiece)
+
+import Ghci.Server.Config (Config, cfHTTPPort)
+
+theApp :: Application
+theApp =
+ let st = $(mkSettings mkEmbedded) in
+ staticApp $ st { ssRedirectToIndex = True, ssIndices = [unsafeToPiece "index.html"] }
+
+startConfig :: Config -> IO ()
+startConfig cf = do
+ let p = cfHTTPPort cf
+ putStrLn $ "Starting HTTP server on port " ++ show p
+ void $ forkIO $ run (cfHTTPPort cf) theApp
diff --git a/src/Ghci/Server/Http/Stage0.hs b/src/Ghci/Server/Http/Stage0.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server/Http/Stage0.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ghci.Server.Http.Stage0 (mkEmbedded) where
+
+import qualified Data.ByteString.Lazy as BL
+import WaiAppStatic.Storage.Embedded
+
+mkEmbedded :: IO [EmbeddableEntry]
+mkEmbedded = do
+ file <- BL.readFile "html/index.html"
+ let emb = EmbeddableEntry {
+ eLocation = "index.html"
+ , eMimeType = "text/html"
+ , eContent = Left (mempty, file)
+ }
+
+ return [emb]
diff --git a/src/Ghci/Server/Websockets/Internal.hs b/src/Ghci/Server/Websockets/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server/Websockets/Internal.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ghci.Server.Websockets.Internal where
+
+import Control.Concurrent (MVar, forkIO, modifyMVar, modifyMVar_,
+ newMVar, readMVar)
+import Control.Exception (catch)
+import Control.Monad (void, (>=>))
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as Aeson
+import Data.Foldable (traverse_)
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+import qualified Foreign.Store as Store
+import qualified Network.WebSockets as WS
+
+import Ghci.Server.Config (Config, cfWSPort, logStr)
+
+newtype ServerState = ServerState { unServerState :: Map.Map ConnectionID WS.Connection }
+
+type ConnectionID = Int
+
+serverState :: ServerState
+serverState = ServerState Map.empty
+
+addConnection :: WS.Connection -> ServerState -> (ServerState, ConnectionID)
+addConnection c (ServerState mp) = (ServerState (Map.insert k c mp), k) where
+ k = maybe 0 (succ . fst) $ Map.lookupMax mp
+
+deleteConnection :: ConnectionID -> ServerState -> ServerState
+deleteConnection i (ServerState mp) = ServerState (Map.delete i mp)
+
+theStore :: Store.Store (MVar ServerState)
+theStore = Store.Store 0
+
+-- | Send a JSON object to all clients. Throws an exception if 'initialise' has
+-- not been run first.
+send :: ToJSON a => a -> IO ()
+send t = Store.withStore theStore (readMVar >=> go) where
+ go s = traverse_ (`WS.sendTextData` msg) (unServerState s)
+ msg = Aeson.encode t
+
+-- | Start the websocket server using the port specified in the config. Call
+-- once per GHCi session.
+startConfig :: Config -> IO ()
+startConfig c = do
+ let p = cfWSPort c
+ state <- newMVar serverState
+ Store.writeStore theStore state
+ logStr c ("Starting websocket server on port " ++ show p)
+ void $ forkIO (WS.runServer "127.0.0.1" p (application c))
+
+application :: Config -> WS.ServerApp
+application conf pending = do
+ state <- Store.readStore theStore
+ conn <- WS.acceptRequest pending
+ WS.forkPingThread conn 30
+ connID <- modifyMVar state (pure . addConnection conn)
+ logStr conf $ "Accepted connection " ++ show connID
+ let go = (WS.receiveData conn >>= logStr conf . Text.unpack) >> go
+ catch go (closeConnection conf connID)
+
+closeConnection :: Config -> ConnectionID -> WS.ConnectionException -> IO ()
+closeConnection conf connID ex = do
+ logStr conf $ "Closing connection " ++ show connID ++ " due to " ++ show ex
+ state <- Store.readStore theStore
+ modifyMVar_ state (pure . deleteConnection connID)
diff --git a/src/Ghci/Server/Websockets/Message.hs b/src/Ghci/Server/Websockets/Message.hs
new file mode 100644
--- /dev/null
+++ b/src/Ghci/Server/Websockets/Message.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Ghci.Server.Websockets.Message (
+ -- $docs
+ sendText
+ , sendHtml
+ , sendPlot
+ , Message(..)
+ ) where
+
+import Data.Aeson
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import Ghci.Server.Websockets.Internal (send)
+
+-- $docs
+-- This module provides the 'Message' data type, and various constructors for
+-- it. It is intended to be used together with the 'html/index.html' file.
+--
+-- = Usage
+--
+-- 1. Start a GHCi session and run 'Ghci.Websockets.initialiseDef'
+-- 2. Open @html/index.html@ in a browser (it's self-contained, no http server
+-- required)
+-- 3. Use 'sendText', 'sendHtml' and 'sendPlot' to show things
+-- in the browser window.
+
+data Message =
+ MsgText Text.Text -- ^ A string
+ | MsgHtml Text.Text -- ^ An HTML fragment
+ | MsgPlotly [Value] Value
+ -- ^ The 'data' and 'layout' parameters used for 'Plotly.newPlot'
+ -- (see
+ -- https://plot.ly/javascript/plotlyjs-function-reference/#plotlynewplot).
+ -- The first parameter is a list of Plotly traces (See
+ -- https://plot.ly/javascript/reference/,
+ -- "Trace types"), the second parameter is a Plotly layout value (see
+ -- https://plot.ly/javascript/reference/, "Layout")
+
+instance ToJSON Message where
+ toJSON = \case
+ MsgText t -> object ["tag" .= ("text" :: String), "contents" .= t]
+ MsgHtml t -> object ["tag" .= ("html" :: String), "contents" .= t]
+ MsgPlotly dt ly -> object ["tag" .= ("plot" :: String), "contents" .= object ["data" .= dt, "layout" .= ly]]
+
+-- | Show a string.
+--
+-- >>> sendText "hello"
+--
+sendText :: Text -> IO ()
+sendText = send . MsgText
+
+-- | Insert some HTML into the DOM.
+--
+-- >>> sendHtml "Hello
"
+--
+sendHtml :: Text -> IO ()
+sendHtml = send . MsgHtml
+
+-- | Show a Plotly 2D line plot of the given points.
+--
+-- >>> sendPlot [(1, 2), (2, 5), (3, 4), (4, 3)]
+--
+-- >>> sendPlot $ fmap (\i -> let i' = (fromIntegral i / 10) in (i', sin i')) [1..100]
+--
+sendPlot :: [(Double, Double)] -> IO ()
+sendPlot ns = send (MsgPlotly [dt] ly) where
+ ly = object ["margin" .= object ["t" .= (0 :: Int)]]
+ dt =
+ let (xs, ys) = unzip ns in
+ object [ "x" .= xs, "y" .= ys ]
diff --git a/src/Ghci/Websockets.hs b/src/Ghci/Websockets.hs
deleted file mode 100644
--- a/src/Ghci/Websockets.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Ghci.Websockets(
- -- $docs
- --
- initialise
- , initialiseDef
- , broadcast
- -- * Configuration
- , Config(..)
- , Verbosity(..)
- , defaultConfig
- ) where
-
-import Control.Concurrent (MVar, forkIO, modifyMVar, modifyMVar_,
- newMVar, readMVar)
-import Control.Exception (catch)
-import Control.Monad (void, (>=>))
-import Data.Aeson (ToJSON)
-import qualified Data.Aeson as Aeson
-import Data.Foldable (traverse_)
-import qualified Data.Map as Map
-import qualified Data.Text as Text
-import qualified Foreign.Store as Store
-import qualified Network.WebSockets as WS
-
--- $docs
--- This modules implements a websocket server whose state survives GHCi
--- reloads. To use it, run 'initialiseDef' once per GHCi session, and then
--- call 'broadcast' to send a JSON value to all clients that are currently
--- connected. All messages from clients are ignored.
-
--- | What to do with log messages
-data Verbosity =
- Verbose -- ^ Write all log messages to stdout
- | Silent -- ^ Ignore all log messages
- deriving (Eq, Ord, Show)
-
--- | Server configuration
-data Config =
- Config
- { port :: Int -- ^ What port to start the server on
- , verbosity :: Verbosity -- ^ What to do with log messages
- }
-
-logStr :: Config -> String -> IO ()
-logStr c s = case verbosity c of
- Silent -> pure ()
- Verbose -> putStrLn s
-
--- | Default config, use port 9160 and ignore all log messages.
-defaultConfig :: Config
-defaultConfig = Config 9160 Silent
-
-newtype ServerState = ServerState { unServerState :: Map.Map ConnectionID WS.Connection }
-
-type ConnectionID = Int
-
-serverState :: ServerState
-serverState = ServerState Map.empty
-
-addConnection :: WS.Connection -> ServerState -> (ServerState, ConnectionID)
-addConnection c (ServerState mp) = (ServerState (Map.insert k c mp), k) where
- k = maybe 0 (succ . fst) $ Map.lookupMax mp
-
-deleteConnection :: ConnectionID -> ServerState -> ServerState
-deleteConnection i (ServerState mp) = ServerState (Map.delete i mp)
-
-theStore :: Store.Store (MVar ServerState)
-theStore = Store.Store 0
-
--- | Send a JSON object to all clients. Throws an exception if 'initialise' has
--- not been run first.
-broadcast :: ToJSON a => a -> IO ()
-broadcast t = Store.withStore theStore (readMVar >=> go) where
- go s = traverse_ (`WS.sendTextData` msg) (unServerState s)
- msg = Aeson.encode t
-
--- | Start the websocket server using the default config (port 9160). Call once
--- per GHCi session.
-initialiseDef :: IO ()
-initialiseDef = initialise defaultConfig
-
--- | Start the websocket server using the port specified in the config. Call
--- once per GHCi session.
-initialise :: Config -> IO ()
-initialise c@Config{port=p} = do
- state <- newMVar serverState
- Store.writeStore theStore state
- logStr c ("Starting websocket server on port " ++ show p)
- void $ forkIO (WS.runServer "127.0.0.1" p (application c))
-
-application :: Config -> WS.ServerApp
-application conf pending = do
- state <- Store.readStore theStore
- conn <- WS.acceptRequest pending
- WS.forkPingThread conn 30
- connID <- modifyMVar state (pure . addConnection conn)
- logStr conf $ "Accepted connection " ++ show connID
- let go = (WS.receiveData conn >>= logStr conf . Text.unpack) >> go
- catch go (closeConnection conf connID)
-
-closeConnection :: Config -> ConnectionID -> WS.ConnectionException -> IO ()
-closeConnection conf connID ex = do
- logStr conf $ "Closing connection " ++ show connID ++ " due to " ++ show ex
- state <- Store.readStore theStore
- modifyMVar_ state (pure . deleteConnection connID)
diff --git a/src/Ghci/Websockets/Simple.hs b/src/Ghci/Websockets/Simple.hs
deleted file mode 100644
--- a/src/Ghci/Websockets/Simple.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Ghci.Websockets.Simple (
- -- $docs
- broadcastText
- , broadcastHtml
- , broadcastPlot
- -- * Re-exports etc.
- , Message(..)
- , module Websockets
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import qualified Data.Text as Text
-
-import Ghci.Websockets as Websockets
-
--- $docs
--- This module provides the 'Message' data type, and various constructors for
--- it. It is intended to be used together with the 'html/index.html' file.
---
--- = Usage
---
--- 1. Start a GHCi session and run 'Ghci.Websockets.initialiseDef'
--- 2. Open @html/index.html@ in a browser (it's self-contained, no http server
--- required)
--- 3. Use 'broadcastText', 'broadcastHtml' and 'broadcastPlot' to show things
--- in the browser window.
-
-data Message =
- MsgText Text.Text -- ^ A string
- | MsgHtml Text.Text -- ^ An HTML fragment
- | MsgPlotly [Value] Value
- -- ^ The 'data' and 'layout' parameters used for 'Plotly.newPlot'
- -- (see
- -- https://plot.ly/javascript/plotlyjs-function-reference/#plotlynewplot).
- -- The first parameter is a list of Plotly traces (See
- -- https://plot.ly/javascript/reference/,
- -- "Trace types"), the second parameter is a Plotly layout value (see
- -- https://plot.ly/javascript/reference/, "Layout")
-
-instance ToJSON Message where
- toJSON = \case
- MsgText t -> object ["tag" .= ("text" :: String), "contents" .= t]
- MsgHtml t -> object ["tag" .= ("html" :: String), "contents" .= t]
- MsgPlotly dt ly -> object ["tag" .= ("plot" :: String), "contents" .= object ["data" .= dt, "layout" .= ly]]
-
--- | Show a string.
---
--- >>> broadcastText "hello"
---
-broadcastText :: Text -> IO ()
-broadcastText = broadcast . MsgText
-
--- | Insert some HTML into the DOM.
---
--- >>> broadcastHtml "Hello
"
---
-broadcastHtml :: Text -> IO ()
-broadcastHtml = broadcast . MsgHtml
-
--- | Show a Plotly 2D line plot of the given points.
---
--- >>> broadcastPlot [(1, 2), (2, 5), (3, 4), (4, 3)]
---
--- >>> broadcastPlot $ fmap (\i -> let i' = (fromIntegral i / 10) in (i', sin i')) [1..100]
---
-broadcastPlot :: [(Double, Double)] -> IO ()
-broadcastPlot ns = broadcast (MsgPlotly [dt] ly) where
- ly = object ["margin" .= object ["t" .= (0 :: Int)]]
- dt =
- let (xs, ys) = unzip ns in
- object [ "x" .= xs, "y" .= ys ]