From f1ba44150a398fa1826a91070d48e5814a9961f9 Mon Sep 17 00:00:00 2001 From: iphydf Date: Thu, 26 Mar 2020 18:32:35 +0000 Subject: [PATCH] Renamed package to msgpack-rpc-conduit. Also export a slightly smaller API. --- .travis.yml | 32 +++++++++++++- BUILD.bazel | 15 ++++--- ...ack-rpc.cabal => msgpack-rpc-conduit.cabal | 12 +++--- src/Network/MessagePack/Capabilities.hs | 26 ++++++------ src/Network/MessagePack/Client.hs | 25 +++++------ src/Network/MessagePack/Client/Internal.hs | 2 +- src/Network/MessagePack/Interface.hs | 15 ++++++- src/Network/MessagePack/Rpc.hs | 10 +---- src/Network/MessagePack/Server/Basic.hs | 2 +- src/Network/MessagePack/Types/Result.hs | 42 +++++++++++++++++++ stack.yaml | 2 + test/Network/MessagePack/ServerSpec.hs | 4 ++ 12 files changed, 138 insertions(+), 49 deletions(-) rename network-msgpack-rpc.cabal => msgpack-rpc-conduit.cabal (88%) create mode 100644 src/Network/MessagePack/Types/Result.hs diff --git a/.travis.yml b/.travis.yml index 6cadcde..0882226 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,7 +1,15 @@ --- language: generic +dist: xenial os: linux +env: + global: + # HACKAGE_USERNAME=[secure] + - secure: "DXnlBg5xxaXUc0+zvR3bWBZPdllHBLTzSmdZ7dXAiQppAk3Frv+k33b4mJhqvebvYlallB+ZYPNpvv5LJfn7PSlPyq0Vg/jn4tswr1foc2vbQr0U+zDOXLaIlOpDwceZiMeDVBaML1kAdYha4jWgMUoxBx+QFdlp7OZI30Ss//eisbQIrndhFjd4MmeWiiQFmL5SC5mf63xpspV6YLkqHRddC21xgR6YnWrSE6pzRf6v4lRiYj4MlsA/ADlaGa25u/rYvxcg9IXnthF+7DcG4hb/AOBWmMkPBGKhv3lVe2M9cgA57te8jQsv9IGVAca+U9z9wxvdIiXSyqkR15mV0VCMXzfH9xSZHdcLxxW7V9TczCmdf0boTd+ahVn2q+TOfSLKFyYanidB8gxWxoeLY0ba1HeiazsASCeMgWz9yhQyMN9wui1OfnmSo7IFG3cmCfQG5gd/LQGcTJgLtLvrzhDxNc+vrimEP+a+bLEOJ2w4fU0dQrx8vYuzkjHi48o4WhQA7c2m8Qww27YKtBiR6dstw7wTh0SVR91OeDQTk/pVAfNwcsBGPGsac/k0rGGeqK/SpAh6LDL/8daEavc+lYB2FtLolAq1Bg5Tkw47uaS+GAspsPx9bfTB1IRGuSQNrWPuCOylMdeX5SpYkmRdMw1LJBgW6tzgodK8+TXYQd4=" + # HACKAGE_PASSWORD=[secure] + - secure: "JDHHQhgYlQldCfS2aAmresi1wcfgFAobSHXG4QrcOiaIz3d12p4ybccgY31CE52dWTWwKdWXD+3pCVKRwUbEwj1FXvOTYn12E1ykZaewuo/10j6Nnjqa0LUUC/XmGgnDmpIEX8vs0xwgpeFUQmQQUT27G3eeBkPrdLbAW2wfXV52QXzrrajy7Q4F27h8i0GcKUFyLij0V/jOya5zuJddxcCviM383KN0e0RTk4L4HMKc905aPy+2p4fiPGIrthWkdvUZlbcPWLpSTIk5ElcMU3N3gOfncUpLWj9hzubLLVUa0SHa3yu1UvVoDZhJdHRzCt+oeceYOtfhZ1CMO9r9z2QgCsIrd+mRCroIsG/OOTC0dwxN726EAXM1beK7ev3mGWluwEbvPvbKv9Le/FXSIi6N+l9ER9oteh+prRDXNyeHb07FV8Sd+55Js3zQw6dz0fNx5zLLhT1aTQt9JhwQlZ1fRoSwTZTFubFYVGvYJVQiNqFZhCa94CeWiPoAgSCe/OTHZMf0/jPFgCPl4/RM5OaUXkd4mceO4XXZGn+HYP2duInWBg2uI0o8MUQwdObkbpr+0ZxoIxio58Ic/NWunRNcvfG4I+U0NNBgwrP24Xanr09jQO89tdFKCX1iIGmsSt1ka+oIEI81vr/PGHuoU3Qe5m5f8UhkoPclMuDzG4M=" + cache: directories: - $HOME/.stack @@ -14,5 +22,25 @@ script: - hlint . - stylish-haskell-lhs -i . - git diff --exit-code - - travis_wait stack --no-terminal test --coverage - - shc network-msgpack-rpc testsuite + - stack --no-terminal test --coverage + - shc msgpack-rpc-conduit testsuite + - stack sdist --tar-dir . + +deploy: + provider: releases + token: + secure: "tBnLJar+vXhTgYW5/Euqe27vGvefC6HX8pPegNjUdyxQA1WFoMz4J78hfR3xQe0e76CXj/Rdk3kwbc+mqeWgIj2r/bxCSSQ3GuXCQw842NEohpQT0xKG60hsti6X2mcN6prrJ4OLaAjo1Nl54LLe6d7WJbnMqG4omVtBPq/LWE53e7SIOv78WdMGu8UI7kYbzl+NMDhSgA4ODjRIc9bFpqd6eReIkPUfRDQRSIKWQz3ifWtiuDOEZkWymkX/9hEii+rNMnkkEBShqs06QFZmffHgRp0b/rYd+EOgpvDDMhtdQDTK6RyjYn12mQHJN0Vlfw/5tkaMv7CFcKbxKN5V/Spf7h6h7yOJMLyKhZCL4NCEhFQHbQr1vy1VQy81AnEZZtVWc0yfjc8iq+W8oJnt+bGn3SFnYrntZomVwj+/+9cOYknoqY6OB9IVnEUwKfdXNLrdy6fttBXzIhhYzmdARChglW/s8CRqGjspzZ5Dn+FzZdehYDeW/of8eBfMfhRZ+wfNswAbxU/JOSzNOk4yMidmoY2W2jBhY1YV7tNVDInuuGuLuiZxzrWmC3/6+qwPGYud2WWN0Xu01Qf7/PzXkgvdJRK1dhMZl/t/pfkcbbAUPeyVgEu5LfDcsnJOmCCUJ0FqWEk5dCQOGQ2+OfcM1DzdaCFTTL9jxgrnRzsPluk=" + file: msgpack-rpc-conduit-0.0.6.tar.gz + skip_cleanup: true + on: + repo: TokTok/hs-msgpack-rpc-conduit + tags: true + +after_deploy: + - mkdir -p "$HOME/.stack/upload" + - echo "{\"username\":\"$HACKAGE_USERNAME\",\"password\":\"$HACKAGE_PASSWORD\"}" > $HOME/.stack/upload/credentials.json + - stack --no-terminal upload . + +# Only build pull requests and releases, don't build master on pushes, +# except through api or cron. +if: type IN (pull_request, api, cron) OR tag IS present diff --git a/BUILD.bazel b/BUILD.bazel index d8eaed6..082763f 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -3,19 +3,23 @@ load("@rules_haskell//haskell:defs.bzl", "haskell_library") load("//third_party/haskell/hspec-discover:build_defs.bzl", "hspec_test") load("//tools/project:build_defs.bzl", "project") +VERSION = "0.0.6" + project( license = "hs-msgpack", + standard_travis = True, + version = VERSION, ) haskell_library( - name = "hs-msgpack-rpc", + name = "hs-msgpack-rpc-conduit", srcs = glob(["src/**/*.*hs"]), compiler_flags = ["-Wno-unused-imports"], src_strip_prefix = "src", - version = "0.0.6", + version = VERSION, visibility = ["//visibility:public"], deps = [ - "//hs-msgpack", + "//hs-msgpack-binary", "//hs-msgpack-types", hazel_library("base"), hazel_library("binary"), @@ -35,10 +39,11 @@ haskell_library( ) hspec_test( - name = "test", + name = "testsuite", + size = "small", compiler_flags = ["-Wno-unused-imports"], deps = [ - ":hs-msgpack-rpc", + ":hs-msgpack-rpc-conduit", hazel_library("async"), hazel_library("base"), hazel_library("bytestring"), diff --git a/network-msgpack-rpc.cabal b/msgpack-rpc-conduit.cabal similarity index 88% rename from network-msgpack-rpc.cabal rename to msgpack-rpc-conduit.cabal index c7b3814..9ce484f 100644 --- a/network-msgpack-rpc.cabal +++ b/msgpack-rpc-conduit.cabal @@ -1,4 +1,4 @@ -name: network-msgpack-rpc +name: msgpack-rpc-conduit version: 0.0.6 synopsis: A MessagePack-RPC Implementation homepage: http://msgpack.org/ @@ -20,7 +20,7 @@ description: source-repository head type: git - location: https://github.com/TokTok/msgpack-haskell.git + location: https://github.com/TokTok/hs-msgpack-rpc-conduit.git library default-language: Haskell2010 @@ -43,6 +43,7 @@ library Network.MessagePack.Server.Basic Network.MessagePack.Types.Client Network.MessagePack.Types.Error + Network.MessagePack.Types.Result Network.MessagePack.Types.Server Network.MessagePack.Types.Spec build-depends: @@ -54,13 +55,12 @@ library , conduit-extra , data-default-class , data-default-instances-base - , data-msgpack >= 0.0.11 - , data-msgpack-types >= 0.0.1 , exceptions , monad-control + , msgpack-binary >= 0.0.11 + , msgpack-types >= 0.0.1 , mtl , network < 3 - , tagged , text , unliftio-core @@ -78,6 +78,6 @@ test-suite testsuite , async , bytestring , hspec + , msgpack-rpc-conduit , mtl , network < 3 - , network-msgpack-rpc diff --git a/src/Network/MessagePack/Capabilities.hs b/src/Network/MessagePack/Capabilities.hs index ceef3f1..e982546 100644 --- a/src/Network/MessagePack/Capabilities.hs +++ b/src/Network/MessagePack/Capabilities.hs @@ -1,28 +1,28 @@ {-# LANGUAGE DeriveGeneric #-} module Network.MessagePack.Capabilities - ( ServerCapability (..) - , ClientCapability (..) - ) where + ( ServerCapability (..) + , ClientCapability (..) + ) where import Data.MessagePack (MessagePack) import GHC.Generics (Generic) data ServerCapability - = SCapMethodList - -- ^ Server supports method lists and can handle more efficient method codes - -- instead of strings for names. It supports the "internal.methodList" call - -- to return an ordered list of method names. The client can send an index - -- in this list instead of the name itself when performing an RPC call. - deriving (Eq, Generic) + = SCapMethodList + -- ^ Server supports method lists and can handle more efficient method codes + -- instead of strings for names. It supports the "internal.methodList" call + -- to return an ordered list of method names. The client can send an index + -- in this list instead of the name itself when performing an RPC call. + deriving (Eq, Generic) instance MessagePack ServerCapability data ClientCapability - = CCapMethodList - -- ^ Client supports method lists and can send more efficient method codes - -- instead of strings for names. - deriving (Eq, Generic) + = CCapMethodList + -- ^ Client supports method lists and can send more efficient method codes + -- instead of strings for names. + deriving (Eq, Generic) instance MessagePack ClientCapability diff --git a/src/Network/MessagePack/Client.hs b/src/Network/MessagePack/Client.hs index 8724d57..3e5b4ff 100644 --- a/src/Network/MessagePack/Client.hs +++ b/src/Network/MessagePack/Client.hs @@ -2,17 +2,17 @@ {-# LANGUAGE Trustworthy #-} module Network.MessagePack.Client ( -- * MessagePack Client type - Client - , ClientT - , execClient + Basic.Client + , Basic.ClientT + , Basic.execClient , runClient -- * Call RPC method - , call + , Basic.call -- * RPC error - , RpcError (..) - , RpcType + , Basic.RpcError (..) + , Basic.RpcType ) where import Control.Applicative (Applicative, pure) @@ -22,17 +22,18 @@ import qualified Data.ByteString as S import Data.Default.Class (Default (..)) import Data.Default.Instances.Base () -import Network.MessagePack.Capabilities -import Network.MessagePack.Client.Basic +import Network.MessagePack.Capabilities (ClientCapability (..), + ServerCapability (..)) +import qualified Network.MessagePack.Client.Basic as Basic import qualified Network.MessagePack.Client.Internal as Internal import qualified Network.MessagePack.Protocol as Protocol -useDefault :: (Applicative m, Default a) => RpcError -> m a +useDefault :: (Applicative m, Default a) => Basic.RpcError -> m a useDefault _ = pure def -initClient :: Client () +initClient :: Basic.Client () initClient = do caps <- Protocol.capabilitiesC [CCapMethodList] `catch` useDefault when (SCapMethodList `elem` caps) $ do @@ -40,6 +41,6 @@ initClient = do Internal.setMethodList mths -runClient :: S.ByteString -> Int -> Client a -> IO a +runClient :: S.ByteString -> Int -> Basic.Client a -> IO a runClient host port client = - execClient host port (initClient >> client) + Basic.execClient host port (initClient >> client) diff --git a/src/Network/MessagePack/Client/Internal.hs b/src/Network/MessagePack/Client/Internal.hs index 09c62cd..d1289e8 100644 --- a/src/Network/MessagePack/Client/Internal.hs +++ b/src/Network/MessagePack/Client/Internal.hs @@ -20,10 +20,10 @@ import qualified Data.Conduit.Binary as CB import Data.Conduit.Serialization.Binary (sinkGet) import Data.MessagePack (MessagePack (fromObject), Object) -import qualified Data.MessagePack.Types.Result as R import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import qualified Network.MessagePack.Types.Result as R import Network.MessagePack.Interface (IsClientType (..), Returns, ReturnsM) diff --git a/src/Network/MessagePack/Interface.hs b/src/Network/MessagePack/Interface.hs index 2b5b937..9ce72b6 100644 --- a/src/Network/MessagePack/Interface.hs +++ b/src/Network/MessagePack/Interface.hs @@ -7,7 +7,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Network.MessagePack.Interface where +module Network.MessagePack.Interface + ( Interface (..) + , InterfaceM (..) + , IsDocType (..) + , IsClientType (..) + , IsReturnType (..) + , Doc (..) + , Returns + , ReturnsM + , call + , concrete + , interface + , method + ) where import Control.Monad.Catch (MonadThrow) import Control.Monad.Trans (MonadIO) diff --git a/src/Network/MessagePack/Rpc.hs b/src/Network/MessagePack/Rpc.hs index aa1b65c..d018057 100644 --- a/src/Network/MessagePack/Rpc.hs +++ b/src/Network/MessagePack/Rpc.hs @@ -3,9 +3,9 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} module Network.MessagePack.Rpc - ( I.Returns + ( I.Doc (..) + , I.Returns , I.ReturnsM - , I.Doc (..) , method , rpc , docs @@ -34,12 +34,6 @@ class RpcService rpc where docs :: rpc -> (Text, I.Doc (F rpc)) --------------------------------------------------------------------------------- --- --- :: Non-IO RPCs --- --------------------------------------------------------------------------------- - type Rpc f = RpcT IO IO f data RpcT mc ms f = RpcT diff --git a/src/Network/MessagePack/Server/Basic.hs b/src/Network/MessagePack/Server/Basic.hs index c2d0e16..4f4b77c 100644 --- a/src/Network/MessagePack/Server/Basic.hs +++ b/src/Network/MessagePack/Server/Basic.hs @@ -75,10 +75,10 @@ import Data.Conduit.Serialization.Binary (ParseError, sinkGet) import qualified Data.List as List import Data.MessagePack (MessagePack, Object, fromObject, toObject) -import qualified Data.MessagePack.Types.Result as R import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Traversable (sequenceA) +import qualified Network.MessagePack.Types.Result as R import Network.Socket (SocketOption (ReuseAddr), setSocketOption) diff --git a/src/Network/MessagePack/Types/Result.hs b/src/Network/MessagePack/Types/Result.hs new file mode 100644 index 0000000..82b6eb5 --- /dev/null +++ b/src/Network/MessagePack/Types/Result.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE Safe #-} +module Network.MessagePack.Types.Result + ( Result (..) + ) where + +import Control.Applicative (Alternative (..), Applicative (..), (<$>), + (<*>)) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) + +data Result a + = Success a + | Failure String + deriving (Read, Show, Eq, Functor, Foldable, Traversable) + +instance Applicative Result where + pure = Success + + Success f <*> x = fmap f x + Failure msg <*> _ = Failure msg + +instance Alternative Result where + empty = Failure "empty alternative" + + s@Success {} <|> _ = s + _ <|> r = r + +instance Monad Result where + return = Success + fail = Failure + + Success x >>= f = f x + Failure msg >>= _ = Failure msg + +#if (MIN_VERSION_base(4,13,0)) +instance MonadFail Result where + fail = Failure +#endif diff --git a/stack.yaml b/stack.yaml index 39dc92e..6e9171b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,3 +3,5 @@ packages: [.] resolver: lts-14.27 extra-deps: - data-default-instances-base-0.1.0.1@sha256:985a13d7103e45a65f06f277b735ef025636014f0d29dd6de998bc7628e09be9,509 + - msgpack-binary-0.0.14@sha256:46c3cf9090ad07d45c79cb74a94c05548ce9f2b5e9d78a497de80ceb5bf55014,2383 + - msgpack-types-0.0.4@sha256:3b045ea90ba9ba62de9538aa7e7915d1356e2cc34ebdb02f4472ee5b981bcab7,1940 diff --git a/test/Network/MessagePack/ServerSpec.hs b/test/Network/MessagePack/ServerSpec.hs index e9a8177..9fd6137 100644 --- a/test/Network/MessagePack/ServerSpec.hs +++ b/test/Network/MessagePack/ServerSpec.hs @@ -122,6 +122,10 @@ spec = do Server.valType retv `shouldNotBe` "" ) docs + describe "methods" $ + it "can be executed locally" $ + Rpc.local helloR "world" `shouldBe` "Hello, world" + methods :: [Server.Method IO] methods =