Renamed package to msgpack-rpc-conduit.

Also export a slightly smaller API.
TokTok · Mar 26, 2020 · f1ba441 · f1ba441
1 parent 6ad9017
commit f1ba441
Show file tree

Hide file tree

Showing 12 changed files with 138 additions and 49 deletions.
diff --git 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
@@ -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 → msgpack-rpc-conduit.cabal b/network-msgpack-rpc.cabal → 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
@@ -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
@@ -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,24 +22,25 @@ 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
     mths <- Protocol.methodListC
     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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 =