├── .ghci ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── example ├── LICENSE ├── Setup.hs ├── console.html ├── console.js ├── server.hs ├── style.css └── websockets-snap-example.cabal ├── src └── Network │ └── WebSockets │ └── Snap.hs ├── stack.yaml └── websockets-snap.cabal /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | example/cabal.sandbox.config 5 | 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # CHANGELOG 2 | 3 | - 0.10.3.1 (2019-05-06) 4 | * Gracefully close ping threads when ServerApp finishes (by Lorenz 5 | Mösenlechner) 6 | 7 | - 0.10.3.0 (2018-05-13) 8 | * Increase ping thread frequency to every 10s, extend Snap timeout by at 9 | least 60s (by Dmitry Dzhus) 10 | 11 | - 0.10.2.5 12 | * Bump snap-server to 1.1 13 | 14 | - 0.10.2.4 (2017-11-26) 15 | * Bump io-streams to 1.5 16 | 17 | - 0.10.2.3 (2017-07-21) 18 | * Bump websockets to 0.12.0.0 19 | 20 | - 0.10.2.2 21 | * Bump io-streams to 1.4.0.0 22 | 23 | - 0.10.2.1 24 | * Bump websockets to 0.11.0.0 25 | 26 | - 0.10.2.0 27 | * Bump websockets to 0.10.0.0 28 | 29 | - 0.10.1.1 30 | * Add `bytestring-builder` as dependency to fix GHC 7.6 compatibility 31 | 32 | - 0.10.1.0 33 | * Fix issues with timeout tickling 34 | 35 | - 0.10.0.0 36 | * Bump snap-core and snap-server to 1.0.0.0 37 | * Remove git submodules; use hackage for all dependencies 38 | * Use cabal.project file to build example server 39 | 40 | - 0.9.2.0 41 | * Bump websockets to 0.9.5.0 to fix socket closing issues 42 | 43 | - 0.9.1.0 44 | * Fixed interleaved messages issue 45 | 46 | - 0.9.0.0 47 | * Bump websockets dependency 48 | 49 | - 0.8.2.2 50 | * Bump mtl dependency 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Jasper Van der Jeugt 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jasper Van der Jeugt nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | websockets-snap 2 | =============== 3 | 4 | Provides [Snap] integration for the [websockets] library. 5 | 6 | This library must be used with the threaded GHC runtime system. You can do this 7 | by using something like this in your cabal file: 8 | 9 | ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N" 10 | 11 | [Snap]: http://snapframework.com/ 12 | [websockets]: http://jaspervdj.be/websockets/ 13 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | optional-packages: example/*.cabal 4 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Jasper Van der Jeugt 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jasper Van der Jeugt nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/console.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | WebSockets Console 5 | 6 | 8 | 9 | 10 | 11 |
12 |
13 | URI: 15 | 16 |
17 | 24 |
25 | 26 | 27 | -------------------------------------------------------------------------------- /example/console.js: -------------------------------------------------------------------------------- 1 | function appendOutput(cls, text) { 2 | $('#console-output').append('
' + text + '
'); 3 | $('#line').focus(); 4 | } 5 | 6 | $(document).ready(function () { 7 | var ws; 8 | 9 | $('#uri').focus(); 10 | 11 | $('#login').submit(function () { 12 | var uri = $('#uri').val(); 13 | $('#login').css('display', 'none'); 14 | $('#console').css('display', 'block'); 15 | 16 | ws = new WebSocket(uri); 17 | appendOutput('stderr', 'Opening WebSockets connection...\n'); 18 | 19 | ws.onerror = function(event) { 20 | appendOutput('stderr', 'WebSockets error: ' + event.data + '\n'); 21 | }; 22 | 23 | ws.onopen = function() { 24 | appendOutput('stderr', 'WebSockets connection successful!\n'); 25 | }; 26 | 27 | ws.onclose = function() { 28 | appendOutput('stderr', 'WebSockets connection closed.\n'); 29 | }; 30 | 31 | ws.onmessage = function(event) { 32 | appendOutput('stdout', event.data); 33 | }; 34 | 35 | return false; 36 | }); 37 | 38 | $('#console-input').submit(function () { 39 | var line = $('#line').val(); 40 | ws.send(line + '\n'); 41 | appendOutput('stdin', line + '\n'); 42 | $('#line').val(''); 43 | return false; 44 | }); 45 | }); 46 | -------------------------------------------------------------------------------- /example/server.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | 6 | -------------------------------------------------------------------------------- 7 | import Control.Concurrent (forkIO) 8 | import Control.Exception (finally) 9 | import Control.Monad (forever, unless) 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Char8 as BC 12 | import qualified Network.WebSockets as WS 13 | import qualified Network.WebSockets.Snap as WS 14 | import Snap.Core (Snap) 15 | import qualified Snap.Core as Snap 16 | import qualified Snap.Http.Server as Snap 17 | import qualified Snap.Util.FileServe as Snap 18 | import qualified System.IO as IO 19 | import qualified System.Process as Process 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | app :: Snap () 24 | app = Snap.route 25 | [ ("", Snap.ifTop $ Snap.serveFile "console.html") 26 | , ("console.js", Snap.serveFile "console.js") 27 | , ("console/:shell", console) 28 | , ("style.css", Snap.serveFile "style.css") 29 | ] 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | console :: Snap () 34 | console = do 35 | Just shell <- Snap.getParam "shell" 36 | WS.runWebSocketsSnap $ consoleApp $ BC.unpack shell 37 | 38 | 39 | -------------------------------------------------------------------------------- 40 | consoleApp :: String -> WS.ServerApp 41 | consoleApp shell pending = do 42 | (stdin, stdout, stderr, phandle) <- Process.runInteractiveCommand shell 43 | conn <- WS.acceptRequest pending 44 | 45 | _ <- forkIO $ copyHandleToConn stdout conn 46 | _ <- forkIO $ copyHandleToConn stderr conn 47 | _ <- forkIO $ copyConnToHandle conn stdin 48 | 49 | exitCode <- Process.waitForProcess phandle 50 | putStrLn $ "consoleApp ended: " ++ show exitCode 51 | 52 | 53 | -------------------------------------------------------------------------------- 54 | copyHandleToConn :: IO.Handle -> WS.Connection -> IO () 55 | copyHandleToConn h c = do 56 | bs <- B.hGetSome h 1024 57 | unless (B.null bs) $ do 58 | putStrLn $ "> " ++ show bs 59 | WS.sendTextData c bs 60 | copyHandleToConn h c 61 | 62 | 63 | -------------------------------------------------------------------------------- 64 | copyConnToHandle :: WS.Connection -> IO.Handle -> IO () 65 | copyConnToHandle c h = flip finally (IO.hClose h) $ forever $ do 66 | bs <- WS.receiveData c 67 | putStrLn $ "< " ++ show bs 68 | B.hPutStr h bs 69 | IO.hFlush h 70 | 71 | 72 | -------------------------------------------------------------------------------- 73 | main :: IO () 74 | main = Snap.httpServe config app 75 | where 76 | config = 77 | Snap.setErrorLog Snap.ConfigNoLog $ 78 | Snap.setAccessLog Snap.ConfigNoLog $ 79 | Snap.defaultConfig 80 | 81 | -------------------------------------------------------------------------------- /example/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 18px; 3 | font-family: 'Inconsolata', monospace; 4 | font-size: 16px; 5 | background-color: #444; 6 | } 7 | 8 | form { 9 | color: #cfc; 10 | font-family: 'Inconsolata', monospace; 11 | font-size: 16px; 12 | margin-top: 6px; 13 | } 14 | 15 | form input { 16 | background-color: #444; 17 | border: 1px solid #777; 18 | color: #cfc; 19 | font-family: 'Inconsolata', monospace; 20 | font-size: 16px; 21 | margin: 0px; 22 | padding: 0px; 23 | } 24 | 25 | pre { 26 | margin: 0px; 27 | padding: 0px; 28 | display: inline; 29 | } 30 | 31 | pre.stderr { 32 | color: #fcc; 33 | } 34 | 35 | pre.stdout { 36 | color: #ccc; 37 | } 38 | 39 | pre.stdin { 40 | color: #cfc; 41 | } 42 | -------------------------------------------------------------------------------- /example/websockets-snap-example.cabal: -------------------------------------------------------------------------------- 1 | name: websockets-snap-example 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Jasper Van der Jeugt 6 | maintainer: Jasper Van der Jeugt 7 | category: Network 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | executable websockets-snap-example 12 | main-is: server.hs 13 | default-language: Haskell2010 14 | ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N" 15 | 16 | build-depends: 17 | base >= 4 && < 5, 18 | bytestring >= 0.10 && < 0.13, 19 | process >= 1.2 && < 1.7, 20 | snap-core >= 1.0 && < 1.1, 21 | snap-server >= 1.0 && < 1.2, 22 | websockets >= 0.9.5 && < 0.14, 23 | websockets-snap >= 0.10.0.0 && < 0.11 24 | -------------------------------------------------------------------------------- /src/Network/WebSockets/Snap.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | Snap integration for the WebSockets library 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Network.WebSockets.Snap 6 | ( runWebSocketsSnap 7 | , runWebSocketsSnapWith 8 | ) where 9 | 10 | 11 | -------------------------------------------------------------------------------- 12 | import Control.Concurrent (forkIO, myThreadId, threadDelay) 13 | import Control.Exception (Exception (..), 14 | SomeException (..), handle, 15 | throwTo, finally) 16 | import Data.IORef (IORef, newIORef, readIORef, 17 | writeIORef) 18 | import Control.Monad (unless) 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString.Builder as BSBuilder 21 | import qualified Data.ByteString.Builder.Extra as BSBuilder 22 | import qualified Data.ByteString.Char8 as BC 23 | import Data.Typeable (Typeable, cast) 24 | import qualified Network.WebSockets as WS 25 | import qualified Network.WebSockets.Connection as WS 26 | import qualified Network.WebSockets.Stream as WS 27 | import qualified Snap.Core as Snap 28 | import qualified Snap.Types.Headers as Headers 29 | import qualified System.IO.Streams as Streams 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | data ServerAppDone = ServerAppDone 34 | deriving (Eq, Ord, Show, Typeable) 35 | 36 | 37 | -------------------------------------------------------------------------------- 38 | instance Exception ServerAppDone where 39 | toException ServerAppDone = SomeException ServerAppDone 40 | fromException (SomeException e) = cast e 41 | 42 | 43 | -------------------------------------------------------------------------------- 44 | -- | The following function escapes from the current 'Snap.Snap' handler, and 45 | -- continues processing the 'WS.WebSockets' action. The action to be executed 46 | -- takes the 'WS.Request' as a parameter, because snap has already read this 47 | -- from the socket. 48 | runWebSocketsSnap 49 | :: Snap.MonadSnap m 50 | => WS.ServerApp 51 | -> m () 52 | runWebSocketsSnap = runWebSocketsSnapWith WS.defaultConnectionOptions 53 | 54 | 55 | -------------------------------------------------------------------------------- 56 | -- | Variant of 'runWebSocketsSnap' which allows custom options 57 | runWebSocketsSnapWith 58 | :: Snap.MonadSnap m 59 | => WS.ConnectionOptions 60 | -> WS.ServerApp 61 | -> m () 62 | runWebSocketsSnapWith options app = do 63 | rq <- Snap.getRequest 64 | Snap.escapeHttp $ \tickle readEnd writeEnd -> do 65 | 66 | thisThread <- myThreadId 67 | stream <- WS.makeStream (Streams.read readEnd) 68 | (\v -> do 69 | Streams.write (fmap BSBuilder.lazyByteString v) writeEnd 70 | Streams.write (Just BSBuilder.flush) writeEnd 71 | ) 72 | 73 | done <- newIORef False 74 | 75 | let options' = options 76 | { WS.connectionOnPong = do 77 | tickle (max 45) 78 | WS.connectionOnPong options 79 | } 80 | 81 | pc = WS.PendingConnection 82 | { WS.pendingOptions = options' 83 | , WS.pendingRequest = fromSnapRequest rq 84 | , WS.pendingOnAccept = forkPingThread tickle done 85 | , WS.pendingStream = stream 86 | } 87 | (app pc >> throwTo thisThread ServerAppDone) `finally` writeIORef done True 88 | 89 | 90 | -------------------------------------------------------------------------------- 91 | -- | Start a ping thread in the background 92 | forkPingThread :: ((Int -> Int) -> IO ()) -> IORef Bool -> WS.Connection -> IO () 93 | forkPingThread tickle done conn = do 94 | _ <- forkIO pingThread 95 | return () 96 | where 97 | pingThread = handle ignore $ 98 | let loop = do 99 | d <- readIORef done 100 | unless d $ do 101 | WS.sendPing conn (BC.pack "ping") 102 | tickle (max 60) 103 | threadDelay $ 10 * 1000 * 1000 104 | loop in 105 | loop 106 | 107 | ignore :: SomeException -> IO () 108 | ignore _ = return () 109 | 110 | 111 | -------------------------------------------------------------------------------- 112 | -- | Convert a snap request to a websockets request 113 | fromSnapRequest :: Snap.Request -> WS.RequestHead 114 | fromSnapRequest rq = WS.RequestHead 115 | { WS.requestPath = Snap.rqURI rq 116 | , WS.requestHeaders = Headers.toList (Snap.rqHeaders rq) 117 | , WS.requestSecure = Snap.rqIsSecure rq 118 | } 119 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 'lts-13.0' 2 | packages: 3 | - '.' 4 | - 'example/' 5 | save-hackage-creds: false 6 | -------------------------------------------------------------------------------- /websockets-snap.cabal: -------------------------------------------------------------------------------- 1 | Name: websockets-snap 2 | Version: 0.10.3.1 3 | Synopsis: Snap integration for the websockets library 4 | Description: Snap integration for the websockets library 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Jasper Van der Jeugt 8 | Maintainer: Jasper Van der Jeugt 9 | Category: Network 10 | Build-type: Simple 11 | Cabal-version: >= 1.8 12 | 13 | Extra-source-files: 14 | CHANGELOG.md 15 | README.md 16 | 17 | Library 18 | Hs-source-dirs: src 19 | Ghc-options: -Wall 20 | 21 | Exposed-modules: 22 | Network.WebSockets.Snap 23 | 24 | Build-depends: 25 | base >= 4 && < 5, 26 | bytestring >= 0.9 && < 0.13, 27 | bytestring-builder >= 0.10 && < 0.11, 28 | io-streams >= 1.3 && < 1.6, 29 | mtl >= 2.1 && < 2.4, 30 | snap-core >= 1.0 && < 1.1, 31 | snap-server >= 1.0 && < 1.2, 32 | websockets >= 0.9.5 && < 0.14 33 | 34 | Source-repository head 35 | Type: git 36 | Location: https://github.com/jaspervdj/websockets-snap 37 | --------------------------------------------------------------------------------