diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +# 2019-07-14 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2019, Jann Müller +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# ghci-websockets + +With `ghci-websockets` you can send data from GHCi straight to the browser, using a websocket connection that survives GHCi reloads. + +![ghci-websockets.gif](ghci-websockets.gif) + +## 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. + +## 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`. + +## Warning + +This packages uses the `foreign-store` package internally, which is highly unstable. I wouldn't use `ghci-websockets` for anything other than GHCi. + +## License + +BSD-3-Clause, see LICENSE + +## Contributions + +Bug reports, pull requests etc. are welcome! diff --git a/ghci-websockets.cabal b/ghci-websockets.cabal new file mode 100644 --- /dev/null +++ b/ghci-websockets.cabal @@ -0,0 +1,42 @@ +cabal-version: 2.2 +name: ghci-websockets +version: 0.0.1 +license: BSD-3-Clause +license-file: LICENSE +copyright: Copyright (C) 2019 Jann Mueller +maintainer: Jann Müller (j.mueller.11@alumni.ucl.ac.uk) +author: Jann Müller +stability: experimental +homepage: https://github.com/j-mueller/ghci-websockets +bug-reports: https://github.com/j-mueller/ghci-websockets/issues +synopsis: A websocket server that survives GHCi reloads +description: A websocket server that survives GHCi reloads - use your browser to visualise results from the REPL. +category: Language +build-type: Simple +extra-doc-files: + README.md + CHANGELOG.md +extra-source-files: + ghci-websockets.gif + html/index.html + +source-repository head + type: git + location: https://github.com/j-mueller/ghci-websockets + +library + exposed-modules: + Ghci.Websockets + Ghci.Websockets.Simple + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base <= 5, + aeson -any, + foreign-store -any, + websockets -any, + text -any, + containers -any + + diff --git a/ghci-websockets.gif b/ghci-websockets.gif new file mode 100644 Binary files /dev/null and b/ghci-websockets.gif differ diff --git a/html/index.html b/html/index.html new file mode 100644 --- /dev/null +++ b/html/index.html @@ -0,0 +1,51 @@ + + + + + + + + + + + + + +
+ + + + diff --git a/src/Ghci/Websockets.hs b/src/Ghci/Websockets.hs new file mode 100644 --- /dev/null +++ b/src/Ghci/Websockets.hs @@ -0,0 +1,106 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Ghci/Websockets/Simple.hs @@ -0,0 +1,74 @@ +{-# 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 ]