diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Version 1.0.0 + + * Initial release of `servant-websockets`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Echo.hs b/examples/Echo.hs new file mode 100644 --- /dev/null +++ b/examples/Echo.hs @@ -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 diff --git a/examples/Stream.hs b/examples/Stream.hs new file mode 100644 --- /dev/null +++ b/examples/Stream.hs @@ -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 diff --git a/servant-websockets.cabal b/servant-websockets.cabal new file mode 100644 --- /dev/null +++ b/servant-websockets.cabal @@ -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 diff --git a/src/Servant/API/WebSocket.hs b/src/Servant/API/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/WebSocket.hs @@ -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 + } diff --git a/src/Servant/API/WebSocketConduit.hs b/src/Servant/API/WebSocketConduit.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/WebSocketConduit.hs @@ -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 + }