servant-websockets (empty) → 1.0.0
raw patch · 9 files changed
+334/−0 lines, 9 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, bytestring, conduit, exceptions, resourcet, servant-server, servant-websockets, text, wai, wai-websockets, warp, websockets
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +14/−0
- Setup.hs +2/−0
- examples/Echo.hs +38/−0
- examples/Stream.hs +40/−0
- servant-websockets.cabal +65/−0
- src/Servant/API/WebSocket.hs +52/−0
- src/Servant/API/WebSocketConduit.hs +90/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Version 1.0.0++ * Initial release of `servant-websockets`.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Lorenz Moesenlechner (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ 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+OWNER 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.
+ README.md view
@@ -0,0 +1,14 @@+# Introduction++This small library provides two servant endpoints for implementing+websockets and is based on `websockets` and `wai-websockets`.++This library provides two `servant` endpoints: `WebSocket` and+`WebSocketConduit`. The former is a low-level interface for directly+interacting with a `Connection` (see the+[websockets](https://hackage.haskell.org/package/websockets) library+for more information). The latter provides a+[conduit](https://hackage.haskell.org/package/conduit) based endpoint+for JSON serializable input and output.++See the module documentation for examples.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Echo.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Servant.API.WebSocketConduit (WebSocketConduit)++import Data.Aeson (Value)+import Data.Conduit (Conduit)+import Data.Monoid ((<>))+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Servant (Proxy (..), Server, serve)++import qualified Data.Conduit.List as CL+++type API = WebSocketConduit Value Value++startApp :: IO ()+startApp = do+ putStrLn "Starting server on http://localhost:8080"+ run 8080 app++app :: Application+app = serve api server++api :: Proxy API+api = Proxy++server :: Server API+server = echo++echo :: Monad m => Conduit Value m Value+echo = CL.map id++main :: IO ()+main = startApp
+ examples/Stream.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Servant.API.WebSocket (WebSocket)++import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (forM_)+import Data.Text (pack)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Network.WebSockets (Connection, forkPingThread, sendTextData)+import Servant ((:>), Proxy (..), Server, serve)++type WebSocketApi = "stream" :> WebSocket++startApp :: IO ()+startApp = do+ putStrLn "Starting server on http://localhost:8080"+ run 8080 app++app :: Application+app = serve api server++api :: Proxy WebSocketApi+api = Proxy++server :: Server WebSocketApi+server = streamData+ where+ streamData :: MonadIO m => Connection -> m ()+ streamData c = liftIO . forM_ [1..] $ \i -> do+ forkPingThread c 10+ sendTextData c (pack $ show (i :: Int)) >> threadDelay 1000000++main :: IO ()+main = startApp
+ servant-websockets.cabal view
@@ -0,0 +1,65 @@+name: servant-websockets+version: 1.0.0+homepage: https://github.com/moesenle/servant-websockets#readme+synopsis: Small library providing WebSocket endpoints for servant.+description: Small library providing WebSocket endpoints for servant.+license: BSD3+license-file: LICENSE+author: Lorenz Moesenlechner+maintainer: moesenle@gmail.com+copyright: 2017 Lorenz Moesenlechner+category: Servant, Web+build-type: Simple+extra-source-files: README.md CHANGELOG.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Servant.API.WebSocket+ , Servant.API.WebSocketConduit+ build-depends: aeson+ , async+ , base >= 4.7 && < 5+ , bytestring+ , conduit+ , exceptions+ , resourcet+ , servant-server+ , text+ , wai+ , wai-websockets+ , warp+ , websockets+ ghc-options: -Wall+ default-language: Haskell2010++executable websocket-echo+ hs-source-dirs: examples+ main-is: Echo.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: aeson+ , base+ , conduit+ , servant-server+ , servant-websockets+ , wai+ , warp+ default-language: Haskell2010++executable websocket-stream+ hs-source-dirs: examples+ main-is: Stream.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , conduit+ , servant-server+ , servant-websockets+ , text+ , wai+ , warp+ , websockets+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/moesenle/servant-websockets
+ src/Servant/API/WebSocket.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Servant.API.WebSocket where++import Control.Monad (void, (>=>))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource (runResourceT)+import Data.Proxy (Proxy (..))+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.WebSockets (Connection, acceptRequest, defaultConnectionOptions)+import Servant.Server (HasServer (..), ServantErr (..), ServerT, runHandler)+import Servant.Server.Internal.Router (leafRouter)+import Servant.Server.Internal.RoutingApplication (RouteResult (..), runDelayed)++-- | Endpoint for defining a route to provide a web socket. The+-- handler function gets an already negotiated websocket 'Connection'+-- to send and receive data.+--+-- Example:+--+-- > type WebSocketApi = "stream" :> WebSocket+-- >+-- > server :: Server WebSocketApi+-- > server = streamData+-- > where+-- > streamData :: MonadIO m => Connection -> m ()+-- > streamData c = liftIO . forM_ [1..] $ \i -> do+-- > forkPingThread c 10+-- > sendTextData c (pack $ show (i :: Int)) >> threadDelay 1000000+data WebSocket++instance HasServer WebSocket ctx where++ type ServerT WebSocket m = Connection -> m ()++ route Proxy _ app = leafRouter $ \env request respond -> runResourceT $+ runDelayed app env request >>= liftIO . go request respond+ where+ go request respond (Route app') =+ websocketsOr defaultConnectionOptions (runApp app') (backupApp respond) request (respond . Route)+ go _ respond (Fail e) = respond $ Fail e+ go _ respond (FailFatal e) = respond $ FailFatal e++ runApp a = acceptRequest >=> \c -> void (runHandler $ a c)++ backupApp respond _ _ = respond $ Fail ServantErr { errHTTPCode = 426+ , errReasonPhrase = "Upgrade Required"+ , errBody = mempty+ , errHeaders = mempty+ }
+ src/Servant/API/WebSocketConduit.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Servant.API.WebSocketConduit where++import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.Async (race_)+import Control.Monad (forever, (>=>))+import Control.Monad.Catch (handle)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Data.Aeson (FromJSON, ToJSON, decode, encode)+import Data.ByteString.Lazy (fromStrict)+import Data.Conduit (Conduit, runConduitRes, yieldM, (.|))+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.WebSockets (ConnectionException, acceptRequest, defaultConnectionOptions,+ forkPingThread, receiveData, receiveDataMessage, sendClose,+ sendTextData)+import Servant.Server (HasServer (..), ServantErr (..), ServerT)+import Servant.Server.Internal.Router (leafRouter)+import Servant.Server.Internal.RoutingApplication (RouteResult (..), runDelayed)++import qualified Data.Conduit.List as CL++-- | Endpoint for defining a route to provide a websocket. In contrast+-- to the 'WebSocket' endpoint, 'WebSocketConduit' provides a+-- higher-level interface. The handler function must be of type+-- @Conduit i m o@ with @i@ and @o@ being instances of 'FromJSON' and+-- 'ToJSON' respectively. 'await' reads from the web socket while+-- 'yield' writes to it.+--+-- Example:+--+-- >+-- > import Data.Aeson (Value)+-- > import qualified Data.Conduit.List as CL+-- >+-- > type WebSocketApi = "echo" :> WebSocketConduit Value Value+-- >+-- > server :: Server WebSocketApi+-- > server = echo+-- > where+-- > echo :: Monad m => Conduit Value m Value+-- > echo = CL.map id+-- >+--+-- Note that the input format on the web socket is JSON, hence this+-- example only echos valid JSON data.+data WebSocketConduit i o++instance (FromJSON i, ToJSON o) => HasServer (WebSocketConduit i o) ctx where++ type ServerT (WebSocketConduit i o) m = Conduit i (ResourceT IO) o++ route Proxy _ app = leafRouter $ \env request respond -> runResourceT $+ runDelayed app env request >>= liftIO . go request respond+ where+ go request respond (Route cond) =+ websocketsOr+ defaultConnectionOptions+ (runWSApp cond)+ (backupApp respond)+ request (respond . Route)+ go _ respond (Fail e) = respond $ Fail e+ go _ respond (FailFatal e) = respond $ FailFatal e++ runWSApp cond = acceptRequest >=> \c -> handle (\(_ :: ConnectionException) -> return ()) $ do+ forkPingThread c 10+ i <- newEmptyMVar+ race_ (forever $ receiveData c >>= putMVar i) $ do+ runConduitRes $ forever (yieldM . liftIO $ takeMVar i)+ .| CL.mapMaybe (decode . fromStrict)+ .| cond+ .| CL.mapM_ (liftIO . sendTextData c . encode)+ sendClose c ("Out of data" :: Text)+ -- After sending the close message, we keep receiving packages+ -- (and drop them) until the connection is actually closed,+ -- which is indicated by an exception.+ forever $ receiveDataMessage c++ backupApp respond _ _ = respond $ Fail ServantErr { errHTTPCode = 426+ , errReasonPhrase = "Upgrade Required"+ , errBody = mempty+ , errHeaders = mempty+ }