diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/network-messagepack-rpc-websocket.cabal b/network-messagepack-rpc-websocket.cabal new file mode 100644 --- /dev/null +++ b/network-messagepack-rpc-websocket.cabal @@ -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 diff --git a/src/Network/MessagePack/RPC/Client/WebSocket.hs b/src/Network/MessagePack/RPC/Client/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Network/MessagePack/RPC/Client/WebSocket.hs @@ -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 diff --git a/test/Network/MessagePack/RPC/Client/WebSocketSpec.hs b/test/Network/MessagePack/RPC/Client/WebSocketSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/MessagePack/RPC/Client/WebSocketSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}