network-messagepack-rpc-websocket (empty) → 0.1.0.0
raw patch · 6 files changed
+228/−0 lines, 6 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, bytestring, data-msgpack, envy, hspec, network-messagepack-rpc, network-messagepack-rpc-websocket, skews, text, websockets, wss-client
Files
- LICENSE +29/−0
- Setup.hs +2/−0
- network-messagepack-rpc-websocket.cabal +48/−0
- src/Network/MessagePack/RPC/Client/WebSocket.hs +44/−0
- test/Network/MessagePack/RPC/Client/WebSocketSpec.hs +104/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2018, IIJ Innovation Institute Inc.+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 the copyright holders 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 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ network-messagepack-rpc-websocket.cabal view
@@ -0,0 +1,48 @@+name: network-messagepack-rpc-websocket+version: 0.1.0.0+synopsis: WebSocket backend for MessagePack RPC+description: WebSocket backend for "network-messagepack-rpc"+homepage: https://github.com/iij-ii/network-messagepack-rpc-websocket+license: BSD3+license-file: LICENSE+author: Yuji Yamamoto and Kazu Yamamoto+maintainer: yuji-yamamoto@iij.ad.jp, kazu@iij.ad.jp+category: Network+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Network.MessagePack.RPC.Client.WebSocket+ build-depends:+ base >= 4.7 && < 5+ , network-messagepack-rpc+ , text+ , websockets+ , wss-client >= 0.2+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Network.MessagePack.RPC.Client.WebSocketSpec+ build-depends: base+ , QuickCheck+ , async+ , bytestring+ , data-msgpack+ , envy+ , hspec+ , network-messagepack-rpc+ , network-messagepack-rpc-websocket+ , skews+ , text+ , wss-client+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/iij-ii/network-messagepack-rpc-websocket
+ src/Network/MessagePack/RPC/Client/WebSocket.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++-- | MessagePack RPC Client based on WebSocket.+module Network.MessagePack.RPC.Client.WebSocket (+ -- * Config+ Config(..)+ , NotificationHandler+ , RequestHandler+ , Logger+ , Formatter+ , defaultConfig+ -- * Backend+ , Backend(..)+ -- * Client+ , URL+ , Client+ , withClient+ -- * Call and reply+ , Result+ , call+ , reply+ ) where++import qualified Data.Text as T+import qualified Network.WebSockets.Client as Ws++import Network.MessagePack.RPC.Client hiding (withClient)+import qualified Network.MessagePack.RPC.Client as RPC (withClient)++-- | URL for websocket end points.+type URL = String++-- | Executing the action in the 3rd argument with a 'Client'.+withClient+ :: URL -- ^ URL+ -> Config -- ^ Configuration+ -> (Client -> IO a) -- ^ Action+ -> IO a+withClient url config action = Ws.withConnection url $ \conn -> do+ Ws.forkPingThread conn 30+ let backend = Backend (Ws.sendBinaryData conn)+ (Ws.receiveData conn)+ (Ws.sendClose conn ("Bye!" :: T.Text))+ RPC.withClient config backend action
+ test/Network/MessagePack/RPC/Client/WebSocketSpec.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.MessagePack.RPC.Client.WebSocketSpec+ ( main+ , spec+ ) where++import Control.Applicative (empty, (<|>))+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async,+ forConcurrently,+ wait)+import Data.ByteString.Char8 ()+import qualified Data.MessagePack as MsgPack+import qualified Data.Text ()+import qualified Network.WebSockets.Skews as Skews+import System.Envy (FromEnv, decodeEnv,+ env, fromEnv)+import Test.Hspec+import Text.Read (readMaybe)++import qualified Data.MessagePack.RPC as Rpc+import qualified Network.MessagePack.RPC.Client.WebSocket as Rpc+++-- `main` is here so that this module can be run from GHCi on its own. It is+-- not needed for automatic spec discovery.+main :: IO ()+main = hspec spec+++newtype PortNumber = PortNumber Int deriving (Eq, Show)++instance FromEnv PortNumber where+ fromEnv = do+ mpn <- (readMaybe <$> env "WSS_CLIENT_TEST_SERVER_PORT") <|> pure (Just 8614)+ PortNumber <$> maybe empty pure mpn+++spec :: Spec+spec = describe "call" $ do+ Right (PortNumber pn) <- runIO decodeEnv++ let host = "localhost"+ server <- runIO $ Skews.start $ Skews.Args host pn++ let withClient =+ Rpc.withClient ("ws://" ++ host ++ ":" ++ show pn) Rpc.defaultConfig++ before_ (Skews.reinit server) $ do+ it+ "when several threads call, every thread should receive corresponding response"+ $ do+ Skews.setDefaultRequestHandler server $ \bin -> do+ rpcMsg <- MsgPack.unpack bin+ case rpcMsg of+ Rpc.RequestMessage mid _methodName args ->+ return+ $ Just+ $ MsgPack.pack+ $ Rpc.ResponseMessage mid+ $ Right+ $ head args+ _ -> return Nothing++ let requestIds = [1 .. 10]+ expectedResponses =+ map (Right . MsgPack.ObjectWord) requestIds++ actualResponses <- withClient $ \client ->+ forConcurrently requestIds+ $ Rpc.call client "someMethod"+ . (: [])+ . MsgPack.ObjectWord+ actualResponses `shouldBe` expectedResponses++ it+ "when a client is waiting for a response, any unrelated frames sent to the connection is ignored."+ $ do+ let midSentByClient = 0+ midNotSentByClient = 1+ expectedResponse = MsgPack.ObjectStr "The right response"+ actualResponse <-+ async+ $ withClient+ $ \client -> Rpc.call client+ "someMethod"+ [MsgPack.ObjectStr "request"]+ threadDelay $ 1000 * 1000 -- Wait until connection is established+ Skews.sendToClients server+ $ MsgPack.pack+ $ Rpc.ResponseMessage midNotSentByClient+ $ Right+ $ MsgPack.ObjectStr "Wrong response"+ Skews.sendToClients server+ $ MsgPack.pack+ $ Rpc.NotificationMessage+ "methodName"+ [MsgPack.ObjectStr "notification"]+ Skews.sendToClients server+ $ MsgPack.pack+ $ Rpc.ResponseMessage midSentByClient+ $ Right expectedResponse+ wait actualResponse `shouldReturn` Right expectedResponse
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}