pinch 0.3.5.0 → 0.4.0.0

raw patch · 26 files changed

+1206/−653 lines, 26 filesdep +asyncdep +cerealdep +networkdep ~semigroupsnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: async, cereal, network, network-run

Dependency ranges changed: semigroups

API changes (from Hackage documentation)

Files

• CHANGES.md +22/−1
• README.md +14/−6
• examples/keyvalue/Client.hs +1/−1
• pinch.cabal +100/−89
• src/Pinch.hs +6/−4
• src/Pinch/Client.hs +99/−0
• src/Pinch/Internal/Builder.hs +6/−1
• src/Pinch/Internal/Exception.hs +73/−0
• src/Pinch/Internal/FoldList.hs +0/−6
• src/Pinch/Internal/Generic.hs +2/−17
• src/Pinch/Internal/Parser.hs +0/−215
• src/Pinch/Internal/Pinchable.hs +0/−19
• src/Pinch/Internal/Pinchable/Parser.hs +15/−4
• src/Pinch/Internal/RPC.hs +95/−0
• src/Pinch/Internal/Value.hs +0/−5
• src/Pinch/Protocol.hs +10/−4
• src/Pinch/Protocol/Binary.hs +57/−65
• src/Pinch/Protocol/Compact.hs +40/−53
• src/Pinch/Server.hs +251/−0
• src/Pinch/Transport.hs +124/−0
• tests/Pinch/ClientServerSpec.hs +174/−0
• tests/Pinch/Internal/BuilderParserSpec.hs +16/−15
• tests/Pinch/Internal/ParserSpec.hs +0/−144
• tests/Pinch/Protocol/BinarySpec.hs +3/−3
• tests/Pinch/Protocol/CompactSpec.hs +1/−1
• tests/Pinch/TransportSpec.hs +97/−0

@@ -1,3 +1,25 @@+0.4.0.0 (2021-01-14)+================++Breaking changes:++-   The protocol parsers now use the cereal library and the Pinch.Protocol.Parser module has been removed.+    Custom protocol implementations need to be ported to the cereal parsers. (#28)+-   Use new header format for binary protocol. This fixes some compatibility issues with thrift libraries+    for other languages. (#33)++Other changes:++-   Add implementations of the framed/unframed transports (`Pinch.Transport`, #29).+-   Add Thrift RPC client/server functionality (`Pinch.Server`/`Pinch.Client`).+-   A new code generator, `pinch-gen`, is available. It can generate code from Thrift files for use+    with the pinch library. For more details, see https://github.com/phile314/pinch-gen/.++0.3.5.1 (2020-12-29)+====================++-   Compatibility with GHC 8.10+ 0.3.5.0 (2019-09-25) ==================== @@ -95,4 +117,3 @@ ====================  -   Initial release.-

@@ -1,12 +1,12 @@ -[![build-status]](https://travis-ci.org/abhinav/pinch)+[![build]](https://github.com/abhinav/pinch)  `pinch` aims to provide an alternative implementation of Apache Thrift for Haskell. The `pinch` library itself acts only as a serialization library. Types specify their Thrift encoding by defining instances of the `Pinchable` typeclass, which may be done by hand or automatically with the use of Generics. -  [build-status]: https://travis-ci.org/abhinav/pinch.svg?branch=master+  [build]: https://github.com/abhinav/pinch/workflows/build/badge.svg  Haddock documentation for this package is avilable on [Hackage] and [here]. @@ -77,9 +77,17 @@ -   Binary -   Compact -Caveats--------+Supported Transports+-------------------- --   There is no code generation or template haskell support yet so types from-    the Thrift file will have to be translated by hand.+The following Thrift transports are supported: +-   Framed+-   Unframed++Code Generation+---------------++If you prefer to generate Haskell code from the Thrift files instead of writing+the necessary Haskell code by hand, you can use the experimental pinch-gen+code generator to do so. For further details see https://github.com/phile314/pinch-gen/ .

@@ -43,7 +43,7 @@     , setValue = mkRequest "setValue"     }   where-    baseRequest = fromMaybe (error "Invalid URL") (HTTP.parseUrl url)+    baseRequest = fromMaybe (error "Invalid URL") (HTTP.parseUrlThrow url)      encode = P.encodeMessage P.binaryProtocol     decode = P.decodeMessage P.binaryProtocol

@@ -1,118 +1,129 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack------ hash: a26aa0d54b7b1bd93ac84d5f821dcc0245b6df6ff10cb67dda63ee3f7f879551  name:           pinch-version:        0.3.5.0-cabal-version:  >= 1.10-build-type:     Simple-license:        BSD3-license-file:   LICENSE-maintainer:     mail@abhinavg.net-homepage:       https://github.com/abhinav/pinch#readme-bug-reports:    https://github.com/abhinav/pinch/issues+version:        0.4.0.0 synopsis:       An alternative implementation of Thrift for Haskell. description:    This library provides machinery for types to specify how they can be                 serialized and deserialized into/from Thrift payloads. It makes no                 assumptions on how these payloads are sent or received and performs no code                 generation. Types may specify how to be serialized and deserialized by-                defining instances of the @Pinchable@ typeclass by hand, or with-                automatically derived instances by using generics. Check the documentation-                in the "Pinch" module for more information.+                defining instances of the @Pinchable@ typeclass by hand, with+                automatically derived instances by using generics or by using the pinch-gen code+                generator. Check the documentation in the "Pinch" module for more information.                 .                 /What is Thrift?/ Apache Thrift provides an interface description language,                 a set of communication protocols, and a code generator and libraries for                 various programming languages to interact with the generated code. Pinch                 aims to provide an alternative implementation of Thrift for Haskell. category:       Development+homepage:       https://github.com/abhinav/pinch#readme+bug-reports:    https://github.com/abhinav/pinch/issues author:         Abhinav Gupta+maintainer:     mail@abhinavg.net+license:        BSD3+license-file:   LICENSE+tested-with:    GHC == 8.10.2, GHC == 8.8.3, GHC == 8.6.5, GHC == 8.4.4+build-type:     Simple extra-source-files:+    README.md+    CHANGES.md     bench/pinch-bench/Bench.hs     bench/pinch-bench/pinch-bench.cabal-    CHANGES.md     examples/keyvalue/Client.hs-    examples/keyvalue/keyvalue.cabal-    examples/keyvalue/keyvalue.thrift     examples/keyvalue/Server.hs     examples/keyvalue/Setup.hs     examples/keyvalue/Types.hs-    README.md+    examples/keyvalue/keyvalue.cabal+    examples/keyvalue/keyvalue.thrift  source-repository head-    type: git-    location: https://github.com/abhinav/pinch+  type: git+  location: https://github.com/abhinav/pinch  library-    hs-source-dirs:-        src-    ghc-options: -Wall-    build-depends:-        array >=0.5,-        base >=4.7 && <5,-        bytestring >=0.10 && <0.11,-        containers >=0.5 && <0.7,-        deepseq >=1.3 && <1.5,-        ghc-prim,-        hashable >=1.2 && <1.3,-        semigroups >=0.18 && <0.19,-        text >=1.2 && <1.3,-        unordered-containers >=0.2 && <0.3,-        vector >=0.10 && <0.13-    build-tools:-        hspec-discover >=2.1-    exposed-modules:-        Pinch-        Pinch.Internal.Builder-        Pinch.Internal.FoldList-        Pinch.Internal.Generic-        Pinch.Internal.Message-        Pinch.Internal.Parser-        Pinch.Internal.Pinchable-        Pinch.Internal.TType-        Pinch.Internal.Value-        Pinch.Protocol-        Pinch.Protocol.Binary-        Pinch.Protocol.Compact-    other-modules:-        Pinch.Internal.Bits-        Pinch.Internal.Pinchable.Parser-        Paths_pinch-    default-language: Haskell2010+  exposed-modules:+      Pinch+      Pinch.Client+      Pinch.Internal.Builder+      Pinch.Internal.Exception+      Pinch.Internal.FoldList+      Pinch.Internal.Generic+      Pinch.Internal.Message+      Pinch.Internal.Pinchable+      Pinch.Internal.RPC+      Pinch.Internal.TType+      Pinch.Internal.Value+      Pinch.Protocol+      Pinch.Protocol.Binary+      Pinch.Protocol.Compact+      Pinch.Server+      Pinch.Transport+  other-modules:+      Pinch.Internal.Bits+      Pinch.Internal.Pinchable.Parser+      Paths_pinch+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-tool-depends:+      hspec-discover:hspec-discover >=2.1+  build-depends:+      array >=0.5+    , base >=4.7 && <5+    , bytestring >=0.10 && <0.11+    , cereal >=0.5.8.1 && <0.6+    , containers >=0.5 && <0.7+    , deepseq >=1.3 && <1.5+    , ghc-prim+    , hashable >=1.2 && <1.4+    , network >=3.1 && <3.2+    , semigroups >=0.18 && <0.20+    , text >=1.2 && <1.3+    , unordered-containers >=0.2 && <0.3+    , vector >=0.10 && <0.13+  default-language: Haskell2010  test-suite pinch-spec-    type: exitcode-stdio-1.0-    main-is: Spec.hs-    hs-source-dirs:-        tests-    ghc-options: -Wall-    build-depends:-        QuickCheck >=2.5,-        base >=4.7 && <5,-        bytestring >=0.10 && <0.11,-        containers >=0.5 && <0.7,-        hspec >=2.0,-        pinch,-        semigroups >=0.18 && <0.19,-        text >=1.2 && <1.3,-        unordered-containers >=0.2 && <0.3,-        vector >=0.10 && <0.13-    build-tools:-        hspec-discover >=2.1-    other-modules:-        Pinch.Arbitrary-        Pinch.Expectations-        Pinch.Internal.BuilderParserSpec-        Pinch.Internal.BuilderSpec-        Pinch.Internal.FoldListSpec-        Pinch.Internal.GenericSpec-        Pinch.Internal.ParserSpec-        Pinch.Internal.PinchableSpec-        Pinch.Internal.TTypeSpec-        Pinch.Internal.Util-        Pinch.Internal.ValueSpec-        Pinch.Protocol.BinarySpec-        Pinch.Protocol.CompactSpec-        Paths_pinch-    default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Pinch.Arbitrary+      Pinch.ClientServerSpec+      Pinch.Expectations+      Pinch.Internal.BuilderParserSpec+      Pinch.Internal.BuilderSpec+      Pinch.Internal.FoldListSpec+      Pinch.Internal.GenericSpec+      Pinch.Internal.PinchableSpec+      Pinch.Internal.TTypeSpec+      Pinch.Internal.Util+      Pinch.Internal.ValueSpec+      Pinch.Protocol.BinarySpec+      Pinch.Protocol.CompactSpec+      Pinch.TransportSpec+      Paths_pinch+  hs-source-dirs:+      tests+  ghc-options: -Wall+  build-tool-depends:+      hspec-discover:hspec-discover >=2.1+  build-depends:+      QuickCheck >=2.5+    , async >=2.2.2 && <2.3+    , base >=4.7 && <5+    , bytestring >=0.10 && <0.11+    , cereal >=0.5.8.1 && <0.6+    , containers >=0.5 && <0.7+    , hspec >=2.0+    , network >=3.1 && <3.2+    , network-run >=0.2.4 && <0.3+    , pinch+    , semigroups >=0.18 && <0.20+    , text >=1.2 && <1.3+    , unordered-containers >=0.2 && <0.3+    , vector >=0.10 && <0.13+  default-language: Haskell2010

@@ -148,9 +148,11 @@     ) where  import Control.Monad-import Data.ByteString (ByteString)-import Data.Int        (Int32)-import Data.Text       (Text)+import Data.ByteString    (ByteString)+import Data.Int           (Int32)+import Data.Serialize.Get (runGetState)+import Data.Text          (Text)+import Data.Tuple         (swap)  import Pinch.Internal.Builder   (runBuilder) import Pinch.Internal.Generic@@ -217,7 +219,7 @@ -- Right ("\NUL\NUL\NUL",[1,2,3,4,5]) -- decodeWithLeftovers :: Pinchable a => Protocol -> ByteString -> Either String (ByteString, a)-decodeWithLeftovers p = deserializeValue' p >=> traverse (runParser . unpinch)+decodeWithLeftovers p bs = (swap <$> runGetState (deserializeValue' p) bs 0) >>= traverse (runParser . unpinch) {-# INLINE decodeWithLeftovers #-}  ------------------------------------------------------------------------------

@@ -0,0 +1,99 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}++module Pinch.Client+  (+    -- * Basic Thrift client+    Client+  , client+  , Channel+  , createChannel+  , createChannel1++  , ThriftCall(..)+  , ThriftClient(..)+  , callOrThrow++    -- * Multiplexing Client+  , MultiplexClient+  , multiplexClient+++    -- * Errors+  , ApplicationException(..)+  , ExceptionType(..)+  , ThriftError(..)+  ) where++import           Control.Exception        (throwIO)++import qualified Data.Text                as T++import           Pinch.Internal.Exception+import           Pinch.Internal.Message+import           Pinch.Internal.Pinchable+import           Pinch.Internal.RPC+import           Pinch.Internal.TType++-- | A simple Thrift Client.+newtype Client = Client Channel++-- | Instantiates a new Thrift client.+client :: Channel -> Client+client = Client++-- | A call to a Thrift server resulting in the return datatype `a`.+data ThriftCall a where+  TCall :: (Pinchable req, Tag req ~ TStruct, Pinchable res, Tag res ~ TStruct)+    => !T.Text -> !req -> ThriftCall res+  TOneway :: (Pinchable req, Tag req ~ TStruct) => !T.Text -> !req -> ThriftCall ()++class ThriftClient c where+  -- | Calls a Thrift service and returns the result/error data structure.+  -- Application-level exceptions defined in the thrift service are returned+  -- as part of the result/error data structure.+  call :: c -> ThriftCall a -> IO a++instance ThriftClient Client where+  call (Client chan) tcall = do+    case tcall of+      TOneway m r -> do+        writeMessage chan $ Message m Oneway 0 (pinch r)+        pure ()+      TCall m r -> do+        writeMessage chan $ Message m Call 0 (pinch r)+        reply <- readMessage chan+        case reply of+          RREOF -> throwIO $ ThriftError $ "Reached EOF while awaiting reply"+          RRFailure err -> throwIO $ ThriftError $ "Could not read message: " <> T.pack err+          RRSuccess reply' -> case messageType reply' of+            Reply -> case runParser $ unpinch $ messagePayload reply' of+              Right x -> pure x+              Left err -> do+                throwIO $ ThriftError $ "Could not parse reply payload: " <> T.pack err+            Exception -> case runParser $ unpinch $ messagePayload reply' of+              Right (x :: ApplicationException) -> throwIO x+              Left err ->+                throwIO $ ThriftError $ "Could not parse application exception: " <> T.pack err+            t -> throwIO $ ThriftError $ "Expected reply or exception, got " <> T.pack (show t) <> "."++-- | Calls a Thrift service. If an application-level thrift exception as defined in the Thrift service definition+-- is returned by the server, it will be re-thrown using `throwIO`.+callOrThrow :: (ThriftClient c, ThriftResult a) => c -> ThriftCall a -> IO (ResultType a)+callOrThrow client' c = call client' c >>= unwrap++-- | A multiplexing thrift client.+data MultiplexClient = forall c . ThriftClient c => MultiplexClient c ServiceName++-- | Create a new multiplexing thrift client targeting the given service.+multiplexClient :: ThriftClient c => c -> ServiceName -> MultiplexClient+multiplexClient = MultiplexClient++instance ThriftClient MultiplexClient where+  call (MultiplexClient client' (ServiceName serviceName)) tcall = case tcall of+    TOneway r req -> call client' $ TOneway (serviceName <> ":" <> r) req+    TCall r req   -> call client' $ TCall (serviceName <> ":" <> r) req

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module      :  Pinch.Internal.Builder -- Copyright   :  (c) Abhinav Gupta 2015@@ -25,6 +24,8 @@     , doubleBE     , doubleLE     , byteString++    , getSize     ) where  import Data.ByteString              (ByteString)@@ -145,3 +146,7 @@     withForeignPtr fp $ \src ->         BI.memcpy dst (src `plusPtr` off) len {-# INLINE byteString #-}++-- | Returns the number of bytes in the builder.+getSize :: Builder -> Int+getSize (B sz _) = sz

@@ -0,0 +1,73 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}++module Pinch.Internal.Exception+  ( ApplicationException (..)+  , ExceptionType (..)+  , ThriftError(..)+  )+where++import           Control.Exception        (Exception)+import           Data.Int+import           Data.Typeable            (Typeable)+import           Pinch.Internal.Pinchable+import           Pinch.Internal.TType++import qualified Data.Text                as T++-- | Thrift application exception as defined in <https://github.com/apache/thrift/blob/master/doc/specs/thrift-rpc.md#response-struct>.+data ApplicationException+  = ApplicationException+  { appExMessage :: T.Text+  , appExType    :: ExceptionType+  }+  deriving (Show, Eq, Typeable)++instance Exception ApplicationException++instance Pinchable ApplicationException where+  type Tag ApplicationException = TStruct++  pinch p = struct+    [ 1 .= appExMessage p+    , 2 .= appExType p+    ]++  unpinch value = ApplicationException+    <$> value .: 1+    <*> value .: 2++-- | Thrift exception type as defined in <https://github.com/apache/thrift/blob/master/doc/specs/thrift-rpc.md#response-struct>.+data ExceptionType+  -- DO NOT RE-ORDER, the enum values need to match the ones defined in the Thrift specification!+  = Unknown               -- 0+  | UnknownMethod         -- 1+  | InvalidMessageType    -- 2+  | WrongMethodName       -- 3+  | BadSequenceId         -- 4+  | MissingResult         -- 5+  | InternalError         -- 6+  | ProtocolError         -- 7+  | InvalidTransform      -- 8+  | InvalidProtocol       -- 9+  | UnsupportedClientType -- 10+  deriving (Show, Eq, Enum, Bounded)++instance Pinchable ExceptionType where+  type Tag ExceptionType = TEnum++  pinch t = pinch ((fromIntegral $ fromEnum t) :: Int32)++  unpinch v = do+    value <- (fromIntegral :: Int32 -> Int) <$> unpinch v+    if (fromEnum $ minBound @ExceptionType) <= value && value <= (fromEnum $ maxBound @ExceptionType)+      then pure $ toEnum $ fromIntegral value+      else fail $ "Unknown application exception type: " ++ show value++-- | An error occured while processing a thrift call.+-- Signals errors like premature EOF, Thrift protocol parsing failures etc.+data ThriftError = ThriftError T.Text+  deriving (Show, Eq)+instance Exception ThriftError

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -27,14 +26,9 @@  import Prelude hiding (foldr, map, mapM, replicate, sequence) -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif- import Control.DeepSeq (NFData (..)) import Data.Hashable   (Hashable (..)) import Data.List       (intercalate)-import Data.Semigroup import Data.Typeable   (Typeable)  import qualified Control.Monad    as M

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFoldable             #-}@@ -16,12 +15,6 @@ {-# LANGUAGE UndecidableInstances       #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ < 709-{-# LANGUAGE OverlappingInstances       #-}-#define OVERLAP-#else-#define OVERLAP {-# OVERLAPPABLE #-}-#endif -- | -- Module      :  Pinch.Internal.Generic -- Copyright   :  (c) Abhinav Gupta 2015@@ -45,13 +38,6 @@     , Void(..)     ) where --#if __GLASGOW_HASKELL__ < 709-import Data.Foldable    (Foldable)-import Data.Traversable (Traversable)-#endif--import Data.Semigroup import Control.Applicative import Control.DeepSeq     (NFData) import Data.Proxy          (Proxy (..))@@ -74,7 +60,7 @@     combine (VStruct as) (VStruct bs) = VStruct $ as `HM.union` bs  -instance OVERLAP GPinchable a => GPinchable (M1 i c a) where+instance {-# OVERLAPPABLE #-} GPinchable a => GPinchable (M1 i c a) where     type GTag (M1 i c a) = GTag a     gPinch = gPinch . unM1     gUnpinch = fmap M1 . gUnpinch@@ -150,7 +136,7 @@ field :: Functor f => (a -> f b) -> Field n a -> f (Field n b) field f (Field a) = Field <$> f a -instance OVERLAP (Pinchable a, KnownNat n)+instance {-# OVERLAPPABLE #-} (Pinchable a, KnownNat n)   => GPinchable (K1 i (Field n a)) where     type GTag (K1 i (Field n a)) = TStruct     gPinch (K1 (Field a)) = struct [n .= a]@@ -202,7 +188,6 @@         | otherwise = fail $ "Couldn't match enum value " ++ show i       where         val = fromIntegral $ natVal (Proxy :: Proxy n)-    gUnpinch x = fail $ "Failed to read enum. Got " ++ show x  ------------------------------------------------------------------------------ 

@@ -1,215 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types            #-}--- |--- Module      :  Pinch.Internal.Parser--- Copyright   :  (c) Abhinav Gupta 2015--- License     :  BSD3------ Maintainer  :  Abhinav Gupta <mail@abhinavg.net>--- Stability   :  experimental------ Implements a basic parser for binary data. The parser does not do any extra--- book-keeping besides keeping track of the current position in the--- ByteString.-module Pinch.Internal.Parser-    ( Parser-    , runParser-    , runParser'--    , int8-    , word8-    , int16-    , int32-    , int64-    , int64LE-    , double-    , doubleLE-    , take-    ) where--import Control.Applicative-import Control.Monad--import Control.Monad.ST (ST)-import Data.Bits        ((.|.))-import Data.ByteString  (ByteString)-import Data.Int         (Int16, Int32, Int64, Int8)-import Data.Word        (Word8)-import Prelude          hiding (take)--import qualified Control.Monad.ST       as ST-import qualified Data.Array.ST          as A-import qualified Data.Array.Unsafe      as A-import qualified Data.ByteString        as B-import qualified Data.ByteString.Unsafe as BU--import Pinch.Internal.Bits---- | Failure continuation. Called with the failure message.-type Failure   r = String          -> r-type Success a r = ByteString -> a -> r--- ^ Success continuation. Called with the remaining bytestring and the--- result.---- | A simple ByteString parser.-newtype Parser a = Parser-    { unParser :: forall r.-          ByteString   -- Bytestring being parsed-       -> Failure r    -- Failure continuation-       -> Success a r  -- Success continuation-       -> r-    }---instance Functor Parser where-    {-# INLINE fmap #-}-    fmap f (Parser g) = Parser-        $ \b0 kFail kSucc -> g b0 kFail-        $ \b1 a -> kSucc b1 (f a)---instance Applicative Parser where-    {-# INLINE pure #-}-    pure a = Parser $ \b _ kSucc -> kSucc b a--    {-# INLINE (<*>) #-}-    Parser f' <*> Parser a' = Parser-        $ \b0 kFail kSucc -> f' b0 kFail-        $ \b1 f -> a' b1 kFail-        $ \b2 a -> kSucc b2 (f a)---instance Monad Parser where-    {-# INLINE return #-}-    return = pure--    {-# INLINE (>>) #-}-    (>>) = (*>)--    {-# INLINE fail #-}-    fail msg = Parser $ \_ kFail _ -> kFail msg--    {-# INLINE (>>=) #-}-    Parser m >>= k = Parser-        $ \b0 kFail kSucc -> m b0 kFail-        $ \b1 a -> unParser (k a) b1 kFail kSucc----- | Run the parser on the given ByteString. Return either the failure message--- or the result.-runParser :: Parser a -> ByteString -> Either String a-runParser (Parser f) b = f b Left (const Right)-{-# INLINE runParser #-}----- | Run the parser on the given ByteString. Return either the failure message--- or the result and any left-over content.-runParser' :: Parser a -> ByteString -> Either String (ByteString, a)-runParser' (Parser f) b = f b Left (\b' r -> Right (b', r))-{-# INLINE runParser' #-}----- | @take n@ gets exactly @n@ bytes or fails the parse.-take :: Int -> Parser ByteString-take n = Parser $ \b kFail kSucc ->-    let l = B.length b-    in if l >= n-        then let remaining = BU.unsafeDrop n b-                 requested = BU.unsafeTake n b-             in kSucc remaining requested-        else kFail-              ("Input is too short. Expected " ++ show n ++ " bytes. " ++-               "Got " ++ show l ++ " bytes.")-{-# INLINE take #-}----- | Produces the next byte and advances the parser.-int8 :: Parser Int8-int8 = Parser-    $ \b0 kFail kSucc -> case B.uncons b0 of-        Nothing -> kFail "Input is too short. Expected 1 bytes. Got 0 bytes."-        Just (w, b1) -> kSucc b1 (fromIntegral w)-{-# INLINE int8 #-}----- | Produces the next byte and advances the parser.-word8 :: Parser Word8-word8 = fromIntegral <$> int8-{-# INLINE word8 #-}----- | Produces a signed 16-bit integer and advances the parser.-int16 :: Parser Int16-int16 = mk <$> take 2-  where-    {-# INLINE mk #-}-    mk b = fromIntegral $-        (fromIntegral (b `BU.unsafeIndex` 0) `w16ShiftL` 8) .|.-         fromIntegral (b `BU.unsafeIndex` 1)-{-# INLINE int16 #-}----- | Produces a signed 32-bit integer and advances the parser.-int32 :: Parser Int32-int32 = mk <$> take 4-  where-    {-# INLINE mk #-}-    mk b = fromIntegral $-        (fromIntegral (b `BU.unsafeIndex` 0) `w32ShiftL` 24) .|.-        (fromIntegral (b `BU.unsafeIndex` 1) `w32ShiftL` 16) .|.-        (fromIntegral (b `BU.unsafeIndex` 2) `w32ShiftL`  8) .|.-         fromIntegral (b `BU.unsafeIndex` 3)-{-# INLINE int32 #-}----- | Produces a signed 64-bit integer and advances the parser.-int64 :: Parser Int64-int64 = mk <$> take 8-  where-    {-# INLINE mk #-}-    mk b = fromIntegral $-        (fromIntegral (b `BU.unsafeIndex` 0) `w64ShiftL` 56) .|.-        (fromIntegral (b `BU.unsafeIndex` 1) `w64ShiftL` 48) .|.-        (fromIntegral (b `BU.unsafeIndex` 2) `w64ShiftL` 40) .|.-        (fromIntegral (b `BU.unsafeIndex` 3) `w64ShiftL` 32) .|.-        (fromIntegral (b `BU.unsafeIndex` 4) `w64ShiftL` 24) .|.-        (fromIntegral (b `BU.unsafeIndex` 5) `w64ShiftL` 16) .|.-        (fromIntegral (b `BU.unsafeIndex` 6) `w64ShiftL`  8) .|.-         fromIntegral (b `BU.unsafeIndex` 7)-{-# INLINE int64 #-}---- | Produces a signed 64-bit integer (parsed in little endian byte ordering)--- and advances the parser.-int64LE :: Parser Int64-int64LE = mk <$> take 8-  where-    {-# INLINE mk #-}-    mk b = fromIntegral $-        (fromIntegral (b `BU.unsafeIndex` 7) `w64ShiftL` 56) .|.-        (fromIntegral (b `BU.unsafeIndex` 6) `w64ShiftL` 48) .|.-        (fromIntegral (b `BU.unsafeIndex` 5) `w64ShiftL` 40) .|.-        (fromIntegral (b `BU.unsafeIndex` 4) `w64ShiftL` 32) .|.-        (fromIntegral (b `BU.unsafeIndex` 3) `w64ShiftL` 24) .|.-        (fromIntegral (b `BU.unsafeIndex` 2) `w64ShiftL` 16) .|.-        (fromIntegral (b `BU.unsafeIndex` 1) `w64ShiftL`  8) .|.-         fromIntegral (b `BU.unsafeIndex` 0)-{-# INLINE int64LE #-}---- | Produces a 64-bit floating point number and advances the parser.-double :: Parser Double-double = int64 >>= \i -> return (ST.runST (cast i))-{-# INLINE double #-}---- | Produces a 64-bit floating point number (parsed in little endian byte--- ordering) and advances the parser.-doubleLE :: Parser Double-doubleLE = int64LE >>= \i -> return (ST.runST (cast i))-{-# INLINE doubleLE #-}---cast :: (A.MArray (A.STUArray s) a (ST s),-         A.MArray (A.STUArray s) b (ST s)) => a -> ST s b--- As per: http://stackoverflow.com/a/7002812-cast x = A.newArray (0 :: Int, 0) x >>= A.castSTUArray >>= flip A.readArray 0-{-# INLINE cast #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE CPP                  #-} {-# LANGUAGE DefaultSignatures    #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}@@ -42,10 +41,6 @@     , parserCatch     ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif- import Data.ByteString (ByteString) import Data.Hashable   (Hashable) import Data.Int        (Int16, Int32, Int64, Int8)@@ -240,61 +235,51 @@     type Tag ByteString = TBinary     pinch = VBinary     unpinch (VBinary b) = return b-    unpinch x = fail $ "Failed to read binary. Got " ++ show x  instance Pinchable BL.ByteString where     type Tag BL.ByteString = TBinary     pinch = VBinary . BL.toStrict     unpinch (VBinary b) = return (BL.fromStrict b)-    unpinch x = fail $ "Failed to read binary. Got " ++ show x  instance Pinchable Text where     type Tag Text = TBinary     pinch = VBinary . TE.encodeUtf8     unpinch (VBinary b) = return . TE.decodeUtf8 $ b-    unpinch x = fail $ "Failed to read string. Got " ++ show x  instance Pinchable TL.Text where     type Tag TL.Text = TBinary     pinch = VBinary . BL.toStrict . TLE.encodeUtf8     unpinch (VBinary b) = return . TL.fromStrict . TE.decodeUtf8 $ b-    unpinch x = fail $ "Failed to read string. Got " ++ show x  instance Pinchable Bool where     type Tag Bool = TBool     pinch = VBool     unpinch (VBool x) = return x-    unpinch x = fail $ "Failed to read boolean. Got " ++ show x  instance Pinchable Int8 where     type Tag Int8 = TByte     pinch = VByte     unpinch (VByte x) = return x-    unpinch x = fail $ "Failed to read byte. Got " ++ show x  instance Pinchable Double where     type Tag Double = TDouble     pinch = VDouble     unpinch (VDouble x) = return x-    unpinch x = fail $ "Failed to read double. Got " ++ show x  instance Pinchable Int16 where     type Tag Int16 = TInt16     pinch = VInt16     unpinch (VInt16 x) = return x-    unpinch x = fail $ "Failed to read i16. Got " ++ show x  instance Pinchable Int32 where     type Tag Int32 = TInt32     pinch = VInt32     unpinch (VInt32 x) = return x-    unpinch x = fail $ "Failed to read i32. Got " ++ show x  instance Pinchable Int64 where     type Tag Int64 = TInt64     pinch = VInt64     unpinch (VInt64 x) = return x-    unpinch x = fail $ "Failed to read i64. Got " ++ show x  instance Pinchable a => Pinchable (Vector a) where     type Tag (Vector a) = TList@@ -303,7 +288,6 @@      unpinch (VList xs) =         V.fromList . FL.toList <$> FL.mapM checkedUnpinch xs-    unpinch x = fail $ "Failed to read list. Got " ++ show x  instance Pinchable a => Pinchable [a] where     type Tag [a] = TList@@ -311,7 +295,6 @@     pinch = VList . FL.map pinch . FL.fromFoldable      unpinch (VList xs) = FL.toList <$> FL.mapM checkedUnpinch xs-    unpinch x = fail $ "Failed to read list. Got " ++ show x  instance   ( Eq k@@ -335,7 +318,6 @@     unpinch (VSet xs) =         FL.foldl' (\s !a -> HS.insert a s) HS.empty         <$> FL.mapM checkedUnpinch xs-    unpinch x = fail $ "Failed to read set. Got " ++ show x  instance (Ord a, Pinchable a) => Pinchable (S.Set a) where     type Tag (S.Set a) = TSet@@ -344,4 +326,3 @@     unpinch (VSet xs) =         FL.foldl' (\s !a -> S.insert a s) S.empty         <$> FL.mapM checkedUnpinch xs-    unpinch x = fail $ "Failed to read set. Got " ++ show x

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP        #-} {-# LANGUAGE Rank2Types #-} -- | -- Module      :  Pinch.Internal.Pinchable.Parser@@ -17,7 +18,9 @@  import Control.Applicative import Control.Monad+import qualified Control.Monad.Fail as Fail + -- | Failure continuation. Called with the failure message. type Failure   r = String  -> r type Success a r = a       -> r@@ -58,9 +61,6 @@             l' (\_ -> r' kFail kSucc) kSucc  instance Monad Parser where-    {-# INLINE fail #-}-    fail msg = Parser $ \kFail _ -> kFail msg-     {-# INLINE return #-}     return = pure @@ -73,6 +73,17 @@             a' kFail $ \a ->             unParser (k a) kFail kSuccB +#if !MIN_VERSION_base(4,13,0)+    -- Monad(fail) was removed in GHC 8.8.1+    {-# INLINE fail #-}+    fail = Fail.fail+#endif++instance Fail.MonadFail Parser where+    {-# INLINE fail #-}+    fail msg = Parser $ \kFail _ -> kFail msg++ instance MonadPlus Parser where     {-# INLINE mzero #-}     mzero = empty@@ -87,5 +98,5 @@ -- | Allows handling parse errors. parserCatch     :: Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b-parserCatch = unParser+parserCatch p f g = unParser p f g {-# INLINE parserCatch #-}

@@ -0,0 +1,95 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies               #-}+module Pinch.Internal.RPC+  ( Channel(..)+  , createChannel+  , createChannel1+  , readMessage+  , writeMessage++  , ReadResult(..)++  , ServiceName(..)+  , ThriftResult(..)++  , Unit(..)+  ) where++import           Data.Hashable            (Hashable (..))+import           Data.String              (IsString (..))+import           Data.Typeable            (Typeable)++import qualified Data.HashMap.Strict      as HM+import qualified Data.Text                as T++import           Pinch.Internal.Message+import           Pinch.Internal.Pinchable (Pinchable (..), Tag)+import           Pinch.Internal.TType     (TStruct)+import           Pinch.Internal.Value     (Value (..))+import           Pinch.Protocol           (Protocol, deserializeMessage',+                                           serializeMessage)+import           Pinch.Transport          (Connection, ReadResult (..),+                                           Transport)++import qualified Pinch.Transport          as Transport++-- | A bi-directional channel to read/write Thrift messages.+data Channel = Channel+  { cTransportIn  :: !Transport+  , cTransportOut :: !Transport+  , cProtocolIn   :: !Protocol+  , cProtocolOut  :: !Protocol+  }++-- | Creates a channel using the same transport/protocol for both directions.+createChannel :: Connection c => c -> (c -> IO Transport) -> Protocol -> IO Channel+createChannel c t p = do+  t' <- t c+  pure $ Channel t' t' p p++-- | Creates a channel.+createChannel1 :: (Transport, Protocol) -> (Transport, Protocol) -> Channel+createChannel1 (tIn, pIn) (tOut, pOut) = Channel tIn tOut pIn pOut++readMessage :: Channel -> IO (ReadResult Message)+readMessage chan = Transport.readMessage (cTransportIn chan) $ deserializeMessage' (cProtocolIn chan)++writeMessage :: Channel -> Message -> IO ()+writeMessage chan msg = Transport.writeMessage (cTransportOut chan) $ serializeMessage (cProtocolOut chan) msg+++newtype ServiceName = ServiceName T.Text+  deriving (Typeable, Eq, Hashable)++instance IsString ServiceName where+  fromString = ServiceName . T.pack+++-- | The Result datatype for a Thrift Service Method.+class (Pinchable a, Tag a ~ TStruct) => ThriftResult a where+  -- | The Haskell type returned when the Thrift call succeeds.+  type ResultType a+  -- | Tries to extract the result from a Thrift call. If the call threw any+  -- of the Thrift exceptions declared for this Thrift service method,+  -- the corresponding Haskell excpetions is thrown using `throwIO`.+  unwrap :: a -> IO (ResultType a)++  -- | Runs the given computation. If it throws any of the exceptions+  -- declared in the Thrift service definition, it is caught and converted+  -- to the corresponding Haskell result datatype constructor.+  wrap :: IO (ResultType a) -> IO a++-- | Result datatype for void methods not throwing any exceptions.+data Unit = Unit++instance Pinchable Unit where+  type Tag Unit = TStruct+  pinch Unit = VStruct mempty+  unpinch (VStruct xs) | HM.null xs = pure Unit+  unpinch x            = fail $ "Failed to read void success. Got " ++ show x++instance ThriftResult Unit where+  type ResultType Unit = ()+  wrap m = Unit <$ m+  unwrap Unit = pure ()

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE RankNTypes          #-}@@ -22,10 +21,6 @@     , castValue     , valueTType     ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Monoid (mempty)-#endif  import Control.DeepSeq     (NFData (..)) import Data.ByteString     (ByteString)

@@ -14,9 +14,11 @@ module Pinch.Protocol     ( Protocol(..)     , deserializeValue+    , deserializeMessage     ) where  import Data.ByteString (ByteString)+import Data.Serialize.Get (Get, runGet)  import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message (Message)@@ -35,14 +37,18 @@     -- Returns a @Builder@ and the total length of the serialized content.      , deserializeValue'-        :: forall a. IsTType a => ByteString -> Either String (ByteString, Value a)+        :: forall a. IsTType a => Get (Value a)     -- ^ Reads a 'Value' from a ByteString and returns leftovers from parse.-    , deserializeMessage :: ByteString -> Either String Message-    -- ^ Reads a 'Message' and its payload from a ByteString.+    , deserializeMessage' :: Get Message+    -- ^ Reads a 'Message' and its payload.     }   -- | Reads a 'Value' from a ByteString. deserializeValue :: forall a. IsTType a                  => Protocol -> ByteString -> Either String (Value a)-deserializeValue proto = fmap snd . deserializeValue' proto+deserializeValue proto = runGet $ deserializeValue' proto++-- | Reads a 'Message' and its payload from a ByteString.+deserializeMessage :: Protocol -> ByteString -> Either String Message+deserializeMessage proto = runGet $ deserializeMessage' proto

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-} -- |@@ -14,31 +13,26 @@ module Pinch.Protocol.Binary (binaryProtocol) where  -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif- import Control.Monad import Data.Bits           (shiftR, (.&.)) import Data.ByteString     (ByteString) import Data.HashMap.Strict (HashMap) import Data.Int            (Int16, Int32, Int8)-import Data.Monoid -import qualified Data.ByteString     as B-import qualified Data.HashMap.Strict as M-import qualified Data.Text.Encoding  as TE+import qualified Data.ByteString        as B+import qualified Data.HashMap.Strict    as M+import qualified Data.Serialize.Get     as G+import qualified Data.Serialize.IEEE754 as G+import qualified Data.Text.Encoding     as TE  import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message-import Pinch.Internal.Parser  (Parser, runParser, runParser') import Pinch.Internal.TType import Pinch.Internal.Value import Pinch.Protocol         (Protocol (..))  import qualified Pinch.Internal.Builder  as BB import qualified Pinch.Internal.FoldList as FL-import qualified Pinch.Internal.Parser   as P   -- | Provides an implementation of the Thrift Binary Protocol.@@ -47,23 +41,24 @@     { serializeValue     = binarySerialize     , deserializeValue'  = binaryDeserialize ttype     , serializeMessage   = binarySerializeMessage-    , deserializeMessage = binaryDeserializeMessage+    , deserializeMessage' = binaryDeserializeMessage     }  ------------------------------------------------------------------------------  binarySerializeMessage :: Message -> Builder binarySerializeMessage msg =+    BB.word8 0x80 <>+    BB.word8 0x01 <>+    BB.word8 0x00 <>+    BB.int8 (messageCode $ messageType msg) <>     string (TE.encodeUtf8 $ messageName msg) <>-    BB.int8 (messageCode (messageType msg)) <> BB.int32BE (messageId msg) <>+    BB.int32BE (messageId msg) <>     binarySerialize (messagePayload msg) -binaryDeserializeMessage :: ByteString -> Either String Message-binaryDeserializeMessage = runParser binaryMessageParser--binaryMessageParser :: Parser Message-binaryMessageParser = do-    size <- P.int32+binaryDeserializeMessage :: G.Get Message+binaryDeserializeMessage = do+    size <- G.getInt32be     if size < 0         then parseStrict size         else parseNonStrict size@@ -74,10 +69,10 @@         unless (version == 1) $             fail $ "Unsupported version: " ++ show version         Message-            <$> TE.decodeUtf8 <$> (P.int32 >>= P.take . fromIntegral)+            <$> TE.decodeUtf8 <$> (G.getInt32be >>= G.getBytes . fromIntegral)             <*> typ-            <*> P.int32-            <*> binaryParser ttype+            <*> G.getInt32be+            <*> binaryDeserialize ttype       where         version = (0x7fff0000 .&. versionAndType) `shiftR` 16 @@ -89,24 +84,21 @@     -- name~4 type:1 seqid:4 payload     parseNonStrict nameLength =         Message-            <$> TE.decodeUtf8 <$> P.take (fromIntegral nameLength)+            <$> TE.decodeUtf8 <$> G.getBytes (fromIntegral nameLength)             <*> parseMessageType-            <*> P.int32-            <*> binaryParser ttype+            <*> G.getInt32be+            <*> binaryDeserialize ttype  -parseMessageType :: Parser MessageType-parseMessageType = P.int8 >>= \code -> case fromMessageCode code of+parseMessageType :: G.Get MessageType+parseMessageType = G.getInt8 >>= \code -> case fromMessageCode code of     Nothing -> fail $ "Unknown message type: " ++ show code     Just t -> return t  ------------------------------------------------------------------------------ -binaryDeserialize :: TType a -> ByteString -> Either String (ByteString, Value a)-binaryDeserialize t = runParser' (binaryParser t)--binaryParser :: TType a -> Parser (Value a)-binaryParser typ = case typ of+binaryDeserialize :: TType a -> G.Get (Value a)+binaryDeserialize typ = case typ of   TBool   -> parseBool   TByte   -> parseByte   TDouble -> parseDouble@@ -119,81 +111,81 @@   TSet    -> parseSet   TList   -> parseList -getTType :: Int8 -> Parser SomeTType+getTType :: Int8 -> G.Get SomeTType getTType code =     maybe (fail $ "Unknown TType: " ++ show code) return $ fromTypeCode code -parseTType :: Parser SomeTType-parseTType = P.int8 >>= getTType+parseTType :: G.Get SomeTType+parseTType = G.getInt8 >>= getTType -parseBool :: Parser (Value TBool)-parseBool = VBool . (== 1) <$> P.int8+parseBool :: G.Get (Value TBool)+parseBool = VBool . (== 1) <$> G.getInt8 -parseByte :: Parser (Value TByte)-parseByte = VByte <$> P.int8+parseByte :: G.Get (Value TByte)+parseByte = VByte <$> G.getInt8 -parseDouble :: Parser (Value TDouble)-parseDouble = VDouble <$> P.double+parseDouble :: G.Get (Value TDouble)+parseDouble = VDouble <$> G.getFloat64be -parseInt16 :: Parser (Value TInt16)-parseInt16 = VInt16 <$> P.int16+parseInt16 :: G.Get (Value TInt16)+parseInt16 = VInt16 <$> G.getInt16be -parseInt32 :: Parser (Value TInt32)-parseInt32 = VInt32 <$> P.int32+parseInt32 :: G.Get (Value TInt32)+parseInt32 = VInt32 <$> G.getInt32be -parseInt64 :: Parser (Value TInt64)-parseInt64 = VInt64 <$> P.int64+parseInt64 :: G.Get (Value TInt64)+parseInt64 = VInt64 <$> G.getInt64be -parseBinary :: Parser (Value TBinary)-parseBinary = VBinary <$> (P.int32 >>= P.take . fromIntegral)+parseBinary :: G.Get (Value TBinary)+parseBinary = VBinary <$> (G.getInt32be >>= G.getBytes . fromIntegral)  -parseMap :: Parser (Value TMap)+parseMap :: G.Get (Value TMap) parseMap = do     ktype' <- parseTType     vtype' <- parseTType-    count <- P.int32+    count <- G.getInt32be      case (ktype', vtype') of       (SomeTType ktype, SomeTType vtype) -> do         items <- FL.replicateM (fromIntegral count) $-            MapItem <$> binaryParser ktype-                    <*> binaryParser vtype+            MapItem <$> binaryDeserialize ktype+                    <*> binaryDeserialize vtype         return $ VMap items  -parseSet :: Parser (Value TSet)+parseSet :: G.Get (Value TSet) parseSet = do     vtype' <- parseTType-    count <- P.int32+    count <- G.getInt32be      case vtype' of       SomeTType vtype ->-          VSet <$> FL.replicateM (fromIntegral count) (binaryParser vtype)+          VSet <$> FL.replicateM (fromIntegral count) (binaryDeserialize vtype)  -parseList :: Parser (Value TList)+parseList :: G.Get (Value TList) parseList = do     vtype' <- parseTType-    count <- P.int32+    count <- G.getInt32be      case vtype' of       SomeTType vtype ->-        VList <$> FL.replicateM (fromIntegral count) (binaryParser vtype)+        VList <$> FL.replicateM (fromIntegral count) (binaryDeserialize vtype)  -parseStruct :: Parser (Value TStruct)-parseStruct = P.int8 >>= loop M.empty+parseStruct :: G.Get (Value TStruct)+parseStruct = G.getInt8 >>= loop M.empty   where-    loop :: HashMap Int16 SomeValue -> Int8 -> Parser (Value TStruct)+    loop :: HashMap Int16 SomeValue -> Int8 -> G.Get (Value TStruct)     loop fields    0 = return $ VStruct fields     loop fields code = do         vtype' <- getTType code-        fieldId <- P.int16+        fieldId <- G.getInt16be         case vtype' of           SomeTType vtype -> do-            value <- SomeValue <$> binaryParser vtype-            loop (M.insert fieldId value fields) =<< P.int8+            value <- SomeValue <$> binaryDeserialize vtype+            loop (M.insert fieldId value fields) =<< G.getInt8   ------------------------------------------------------------------------------

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE RankNTypes          #-}@@ -15,36 +14,30 @@ -- Implements the Thrift Compact Protocol as a 'Protocol'. module Pinch.Protocol.Compact (compactProtocol) where --#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif- import Control.Monad import Data.Bits           hiding (shift) import Data.ByteString     (ByteString) import Data.HashMap.Strict (HashMap) import Data.Int            (Int16, Int32, Int64) import Data.List           (sortBy)-import Data.Monoid import Data.Ord            (comparing) import Data.Typeable       (Typeable) import Data.Word           (Word64, Word8) -import qualified Data.ByteString     as B-import qualified Data.HashMap.Strict as M-import qualified Data.Text.Encoding  as TE+import qualified Data.ByteString        as B+import qualified Data.HashMap.Strict    as M+import qualified Data.Serialize.IEEE754 as G+import qualified Data.Serialize.Get     as G+import qualified Data.Text.Encoding     as TE  import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message-import Pinch.Internal.Parser  (Parser, runParser, runParser') import Pinch.Internal.TType import Pinch.Internal.Value import Pinch.Protocol         (Protocol (..))  import qualified Pinch.Internal.Builder  as BB import qualified Pinch.Internal.FoldList as FL-import qualified Pinch.Internal.Parser   as P   -- | Provides an implementation of the Thrift Compact Protocol.@@ -53,7 +46,7 @@     { serializeValue     = compactSerialize     , deserializeValue'  = compactDeserialize ttype     , serializeMessage   = compactSerializeMessage-    , deserializeMessage = compactDeserializeMessage+    , deserializeMessage' = compactDeserializeMessage     }  ------------------------------------------------------------------------------@@ -70,20 +63,17 @@     string (TE.encodeUtf8 $ messageName msg) <>     compactSerialize (messagePayload msg) -compactDeserializeMessage :: ByteString -> Either String Message-compactDeserializeMessage = runParser compactMessageParser--compactMessageParser :: Parser Message-compactMessageParser = do-    pid <- P.word8+compactDeserializeMessage :: G.Get Message+compactDeserializeMessage = do+    pid <- G.getWord8     when (pid /= protocolId) $ fail "Invalid protocol ID"-    w <- P.word8+    w <- G.getWord8     let ver = w .&. 0x1f     when (ver /= version) $ fail $ "Unsupported version: " ++ show ver     let code = w `shiftR` 5     msgId <- parseVarint-    msgName <- TE.decodeUtf8 <$> (parseVarint >>= P.take . fromIntegral)-    payload <- compactParser ttype+    msgName <- TE.decodeUtf8 <$> (parseVarint >>= G.getBytes . fromIntegral)+    payload <- compactDeserialize ttype     mtype <- case fromMessageCode code of         Nothing -> fail $ "unknown message type: " ++ show code         Just t -> return t@@ -96,13 +86,10 @@  ------------------------------------------------------------------------------ -compactDeserialize :: TType a -> ByteString -> Either String (ByteString, Value a)-compactDeserialize t = runParser' (compactParser t)--compactParser :: TType a -> Parser (Value a)-compactParser typ = case typ of+compactDeserialize :: TType a -> G.Get (Value a)+compactDeserialize typ = case typ of   TBool      -> do-      n <- P.int8+      n <- G.getInt8       return $ VBool (n == 1)   TByte      -> parseByte   TDouble    -> parseDouble@@ -126,51 +113,51 @@     n' = fromIntegral n :: Word64     -- ensure no sign extension -parseVarint :: Parser Int64+parseVarint :: G.Get Int64 parseVarint = go 0 0   where     go !val !shift = do         when (shift >= 64) $ fail "parseVarint: too wide"-        n <- P.word8+        n <- G.getWord8         let val' = val .|. ((fromIntegral n .&. 0x7f) `shiftL` shift)         if testBit n 7           then go val' (shift + 7)           else return val' -getCType :: Word8 -> Parser SomeCType+getCType :: Word8 -> G.Get SomeCType getCType code =     maybe (fail $ "Unknown CType: " ++ show code) return $ fromCompactCode code -parseByte :: Parser (Value TByte)-parseByte = VByte <$> P.int8+parseByte :: G.Get (Value TByte)+parseByte = VByte <$> G.getInt8 -parseDouble :: Parser (Value TDouble)-parseDouble = VDouble <$> P.doubleLE+parseDouble :: G.Get (Value TDouble)+parseDouble = VDouble <$> G.getFloat64le -parseInt16 :: Parser (Value TInt16)+parseInt16 :: G.Get (Value TInt16) parseInt16 = VInt16 . fromIntegral . zigZagToInt <$> parseVarint -parseInt32 :: Parser (Value TInt32)+parseInt32 :: G.Get (Value TInt32) parseInt32 = VInt32 . fromIntegral . zigZagToInt <$> parseVarint -parseInt64 :: Parser (Value TInt64)+parseInt64 :: G.Get (Value TInt64) parseInt64 = VInt64 . fromIntegral . zigZagToInt <$> parseVarint -parseBinary :: Parser (Value TBinary)+parseBinary :: G.Get (Value TBinary) parseBinary = do     n <- parseVarint     when (n < 0) $         fail $ "parseBinary: invalid length " ++ show n-    VBinary <$> P.take (fromIntegral n)+    VBinary <$> G.getBytes (fromIntegral n)  -parseMap :: Parser (Value TMap)+parseMap :: G.Get (Value TMap) parseMap = do     count <- parseVarint     case count of       0 -> return VNullMap       _ -> do-          tys <- P.word8+          tys <- G.getWord8           SomeCType kctype <- getCType (tys `shiftR` 4)           SomeCType vctype <- getCType (tys .&. 0x0f) @@ -178,35 +165,35 @@               vtype = cTypeToTType vctype            items <- FL.replicateM (fromIntegral count) $-              MapItem <$> compactParser ktype-                      <*> compactParser vtype+              MapItem <$> compactDeserialize ktype+                      <*> compactDeserialize vtype           return $ VMap items   parseCollection     :: (forall a. IsTType a => FL.FoldList (Value a) -> Value b)-    -> Parser (Value b)+    -> G.Get (Value b) parseCollection buildValue = do-    sizeAndType <- P.word8+    sizeAndType <- G.getWord8     SomeCType ctype <- getCType (sizeAndType .&. 0x0f)     count <- case sizeAndType `shiftR` 4 of                  0xf -> parseVarint                  n   -> return $ fromIntegral n     let vtype  = cTypeToTType ctype-    buildValue <$> FL.replicateM (fromIntegral count) (compactParser vtype)+    buildValue <$> FL.replicateM (fromIntegral count) (compactDeserialize vtype) -parseSet :: Parser (Value TSet)+parseSet :: G.Get (Value TSet) parseSet = parseCollection VSet -parseList :: Parser (Value TList)+parseList :: G.Get (Value TList) parseList = parseCollection VList -parseStruct :: Parser (Value TStruct)+parseStruct :: G.Get (Value TStruct) parseStruct = loop M.empty 0   where-    loop :: HashMap Int16 SomeValue -> Int16 -> Parser (Value TStruct)+    loop :: HashMap Int16 SomeValue -> Int16 -> G.Get (Value TStruct)     loop fields lastFieldId = do-        sizeAndType <- P.word8+        sizeAndType <- G.getWord8         SomeCType ctype <- getCType (sizeAndType .&. 0x0f)         case ctype of             CStop -> return (VStruct fields)@@ -219,7 +206,7 @@                   CBoolFalse -> return (SomeValue $ VBool False)                   _          ->                     let vtype = cTypeToTType ctype-                     in SomeValue <$> compactParser vtype+                     in SomeValue <$> compactDeserialize vtype                 loop (M.insert fieldId value fields) fieldId  

@@ -0,0 +1,251 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}++module Pinch.Server+  (+    -- * Thrift Server creation++    ThriftServer (..)+  , createServer+  , Handler(..)+  , Request (..)++    -- * Running a Thrift Server+  , runConnection+  , ThriftError (..)+  , Channel (..)+  , createChannel+  , createChannel1++    -- * Thrift Server context++    -- | The context can be used to pass data from the environment to the thrift server functions.+    -- For example, you could pass the remote host name to the server to use it for logging purposes.+  , Context+  , ContextItem+  , addToContext+  , lookupInContext++    -- * Middlewares+  , multiplex+  , ServiceName (..)+  , onError++    -- * Helper functions++    -- | Functions mostly useful for defining custom `ThriftServer`s.+  , mapRequestMessage+  , getRequestMessage+  , mkApplicationExceptionReply+  ) where++import           Control.Exception        (Exception, SomeException, catchJust,+                                           fromException, throwIO, try)+import           Data.Dynamic             (Dynamic (..), fromDynamic, toDyn)+import           Data.Proxy               (Proxy (..))+import           Data.Typeable            (TypeRep, Typeable, typeOf, typeRep)++import qualified Data.HashMap.Strict      as HM+import qualified Data.Text                as T++import           Pinch.Internal.Exception+import           Pinch.Internal.Message+import           Pinch.Internal.Pinchable+import           Pinch.Internal.RPC+import           Pinch.Internal.TType++import qualified Pinch.Transport          as T++-- | A single request to a thrift server.+data Request out where+  RCall :: !Message -> Request Message+  ROneway :: !Message -> Request ()++deriving instance Show (Request out)++-- | Map the message contained in the request.+mapRequestMessage :: (Message -> Message) -> Request o -> Request o+mapRequestMessage f (RCall m)   = RCall $ f m+mapRequestMessage f (ROneway m) = ROneway $ f m++-- | Extract the message contained in the request.+getRequestMessage :: Request o -> Message+getRequestMessage (RCall m)   = m+getRequestMessage (ROneway m) = m++-- | A `Thrift` server. Takes the context and the request as input and may produces a reply message.+newtype ThriftServer = ThriftServer { unThriftServer :: forall a . Context -> Request a -> IO a }++-- | Allows passing context information to a `ThriftServer`.+-- The context is indexed by type.+newtype Context = Context (HM.HashMap TypeRep Dynamic)++instance Semigroup Context where+  (Context a) <> (Context b) = Context $ a <> b++instance Monoid Context where+  mempty = Context mempty++class Typeable a => ContextItem a where++instance ContextItem ServiceName+++-- | Adds a new item to the context. If an item with the same+-- type is already part of the context, it will be overwritten.+addToContext :: forall i . ContextItem i => i -> Context -> Context+addToContext i (Context m) =+  Context $ HM.insert (typeOf i) (toDyn i) m++-- | Lookup a value in the context.+lookupInContext :: forall i . ContextItem i => Context -> Maybe i+lookupInContext (Context m) = do+  x <- HM.lookup (typeRep (Proxy :: Proxy i)) m+  case fromDynamic @i x of+    Nothing -> error "Impossible!"+    Just y  -> pure y++-- | Create a handler for a request type.+data Handler where+  -- | Handle normal call requests. Must return a result.+  CallHandler :: (Pinchable c, Tag c ~ TStruct, Pinchable r, Tag r ~ TStruct) => (Context -> c -> IO r) -> Handler+  -- | Handle oneway requests. Cannot return any result.+  OnewayHandler :: (Pinchable c, Tag c ~ TStruct) => (Context -> c -> IO ()) -> Handler++-- | Creates a new thrift server processing requests with the function `f`.+--+-- By default, if processing a oneway call fails a haskell exception is thrown which will likely+-- terminate the guilty connection. You may use the `onError` combinator to handle this case+-- more gracefully.+createServer :: (T.Text -> Maybe Handler) -> ThriftServer+createServer f = ThriftServer $ \ctx req ->+  case req of+    RCall msg ->+      case f $ messageName msg of+        Just (CallHandler f') ->+          case runParser $ unpinch $ messagePayload msg of+            Right args -> do+              ret <- f' ctx args+              pure $ Message+                  { messageName = messageName msg+                  , messageType = Reply+                  , messageId   = messageId msg+                  , messagePayload = pinch ret+                  }+            Left err ->+              pure $ mkApplicationExceptionReply msg $+                ApplicationException ("Unable to parse service arguments: " <> T.pack err) InternalError++        Just (OnewayHandler _) ->+          pure $ mkApplicationExceptionReply msg $+            ApplicationException "Expected message type Oneway, got Call." InvalidMessageType+        Nothing ->+          pure $ mkApplicationExceptionReply msg $ ApplicationException "Unknown method name." WrongMethodName++    ROneway msg ->+      -- we cannot return errors to the client as it is a oneway call.+      -- Instead we just throw an exception, possible terminating+      -- the guilty connection.+      case f $ messageName msg of+        Just (OnewayHandler f') -> do+          case runParser $ unpinch $ messagePayload msg of+            Right args -> f' ctx args+            Left err   ->+              throwIO $ ApplicationException ("Unable to parse service arguments: " <> T.pack err) InternalError+        Just (CallHandler _) ->+          throwIO $ ApplicationException "Expected message type Call, got Oneway." InvalidMessageType+        Nothing ->+          throwIO $ ApplicationException "Unknown method name." WrongMethodName++-- | Multiplex multiple services into a single `ThriftServer`.+--+-- The service name is added to the `Context` and may be retrieved using `lookupInContext @ServiceName ctx`.+multiplex :: [(ServiceName, ThriftServer)] -> ThriftServer+multiplex services = ThriftServer $ \ctx req -> do+  case req of+    RCall msg -> go ctx req (pure . mkApplicationExceptionReply msg)+    -- we cannot send the exception back, because it is a oneway call+    -- instead let's just throw it and crash the server+    ROneway _ -> go ctx req throwIO+  where+    srvMap = HM.fromList services++    go :: Context -> Request a -> (ApplicationException -> IO a) -> IO a+    go ctx req onErr = do+      let (prefix, method) = T.span (/= ':') (messageName $ getRequestMessage req)+      let prefix' = ServiceName prefix+      let ctx' = addToContext prefix' ctx+      case prefix' `HM.lookup` srvMap of+        _ | T.null method -> onErr $ ApplicationException "Invalid method name, expecting a colon." WrongMethodName+        Just srv -> do++          reply <- unThriftServer srv ctx' $ mapRequestMessage (\msg -> msg { messageName = T.tail method }) req++          case req of+            ROneway _ -> pure ()+            RCall _   -> pure reply+        Nothing -> onErr $ ApplicationException ("No service with name " <> prefix <> " available.") UnknownMethod++-- | Add error handlers to a `ThriftServer`. Exceptions are caught and not re-thrown, but you may do+-- so by calling `ioThrow` yourself.+onError+  :: Exception e+  => (e -> Maybe a) -- ^ Select exceptions to handle.+  -> (a -> IO Message) -- ^ Error handler for normal method calls.+  -> (a -> IO ()) -- ^ Error handler for oneway calls.+  -> ThriftServer -> ThriftServer+onError sel callError onewayError srv = ThriftServer $+  \ctx req ->+    catchJust sel+      (unThriftServer srv ctx req)+      (\e -> do+        case req of+          RCall _   -> callError e+          ROneway _ -> onewayError e+      )++-- | Run a Thrift server for a single connection.+runConnection :: Context -> ThriftServer -> Channel -> IO ()+runConnection ctx srv chan = do+  msg <- readMessage chan+  case msg of+    T.RREOF -> pure ()+    T.RRFailure err -> do+      throwIO $ ThriftError $ T.pack err+    T.RRSuccess call -> do+      case messageType call of+        Call -> do+          r <- try $ unThriftServer srv ctx (RCall call)+          case r of+            -- if it is already an ApplicationException, we just send it back+            Left (e :: SomeException)+              | Just appEx <- fromException e -> writeMessage chan $ mkApplicationExceptionReply call appEx+            Left (e :: SomeException) -> writeMessage chan $ mkApplicationExceptionReply call $+              ApplicationException ("Could not process request: " <> (T.pack $ show e)) InternalError+            Right x -> writeMessage chan x+        Oneway -> do+          -- no matter what happens, we can never send back an error because the client is not listening for replies+          -- when doing a oneway calls...+          -- Let's just crash the connection in this case, to avoid silently swallowing errors.+          -- `onError` can be used to handle this more gracefully.+          unThriftServer srv ctx (ROneway call)+        -- the client must never send Reply/Exception messages.+        t -> throwIO $+          ApplicationException ("Expected call, got " <> (T.pack $ show t)) InvalidMessageType+      runConnection ctx srv chan++-- | Builds an exception reply given the corresponding request message.+mkApplicationExceptionReply :: Message -> ApplicationException -> Message+mkApplicationExceptionReply req ex = Message+  { messageName = messageName req+  , messageType = Exception+  , messageId = messageId req+  , messagePayload = pinch ex+  }

@@ -0,0 +1,124 @@+{-# LANGUAGE RankNTypes #-}++module Pinch.Transport+  ( Transport(..)+  , framedTransport+  , unframedTransport+  , Connection(..)+  , ReadResult(..)+  ) where++import Data.IORef (newIORef, readIORef, writeIORef)+import Network.Socket (Socket)+import Network.Socket.ByteString (sendAll, recv)+import System.IO (Handle)++import qualified Data.ByteString as BS+import qualified Data.Serialize.Get as G++import qualified Pinch.Internal.Builder as B++class Connection c where+  -- | Gets up to n bytes. Returns an empty bytestring if EOF is reached.+  cGetSome :: c -> Int -> IO BS.ByteString+  -- | Writes the given bytestring.+  cPut :: c -> BS.ByteString -> IO ()++instance Connection Handle where+  cPut = BS.hPut+  cGetSome = BS.hGetSome++instance Connection Socket where+  cPut = sendAll+  cGetSome s n = recv s (min n 4096)++data ReadResult a+  = RRSuccess a+  | RRFailure String+  | RREOF+  deriving (Eq, Show)++-- | A bidirectional transport to read/write messages from/to.+data Transport+  = Transport+  { writeMessage :: B.Builder -> IO ()+  , readMessage  :: forall a . G.Get a -> IO (ReadResult a)+  }++-- | Creates a thrift framed transport. See also <https://github.com/apache/thrift/blob/master/doc/specs/thrift-rpc.md#framed-vs-unframed-transport>.+framedTransport :: Connection c => c -> IO Transport+framedTransport c = pure $ Transport writeMsg readMsg where+  writeMsg msg = do+    cPut c $ B.runBuilder $ B.int32BE (fromIntegral $ B.getSize msg)+    cPut c $ B.runBuilder msg++  readMsg p = do+    szBs <- getExactly c 4+    if BS.length szBs < 4+      then+        pure $ RREOF+      else do+        let sz = fromIntegral <$> G.runGet G.getInt32be szBs+        case sz of+          Right x -> do+            msgBs <- getExactly c x+            pure $ if BS.length msgBs < x+              then+                -- less data has been returned than expected. This means we have reached EOF.+                RREOF+              else+                either RRFailure RRSuccess $ G.runGet p msgBs+          Left s -> pure $ RRFailure $ "Invalid frame size: " ++ show s++-- | Creates a thrift unframed transport. See also <https://github.com/apache/thrift/blob/master/doc/specs/thrift-rpc.md#framed-vs-unframed-transport>.+unframedTransport :: Connection c => c -> IO Transport+unframedTransport c = do+  -- As we do not know how long messages are,+  -- we may read more data then the current message needs.+  -- We keep the leftovers in a buffer so that we may use them+  -- when reading the next message.+  readBuffer <- newIORef mempty+  pure $ Transport writeMsg (readMsg readBuffer)+  where+    writeMsg msg = cPut c $ B.runBuilder msg++    readMsg buf p = do+      bs <- readIORef buf+      bs' <- if BS.null bs then getSome else pure bs+      (leftOvers, r) <- runGetWith getSome p bs'+      writeIORef buf leftOvers+      pure $ r+    getSome = cGetSome c 1024++-- | Runs a Get parser incrementally, reading more input as necessary until a successful parse+-- has been achieved.+runGetWith :: IO BS.ByteString -> G.Get a -> BS.ByteString -> IO (BS.ByteString, ReadResult a)+runGetWith getBs p initial = go (G.runGetPartial p initial)+  where+    go r = case r of+      G.Fail err bs -> do+        pure (bs, RRFailure err)+      G.Done a bs -> do+        pure (bs, RRSuccess a)+      G.Partial cont -> do+        bs <- getBs+        if BS.null bs+          then+            -- EOF+            pure (bs, RREOF)+          else+            go $ cont bs+  +-- | Gets exactly n bytes. If EOF is reached, an empty string is returned.+getExactly :: Connection c => c -> Int -> IO BS.ByteString+getExactly c sz = B.runBuilder <$> go sz mempty+  where+    go :: Int -> B.Builder -> IO B.Builder+    go n b = do+      bs <- cGetSome c n+      let b' = b <> B.byteString bs+      case BS.length bs of+        -- EOF, return what data we might have gotten so far+        0 -> pure mempty+        n' | n' < n -> go (n - n') b'+        _  | otherwise -> pure b'

@@ -0,0 +1,174 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Pinch.ClientServerSpec (spec) where++import           Control.Concurrent       (forkFinally)+import           Control.Concurrent.Async (withAsync)+import           Control.Concurrent.MVar  (MVar, newEmptyMVar, putMVar,+                                           takeMVar)+import           Control.Exception        (bracketOnError, finally, throwIO)+import           Control.Monad            (forever, void)+import           Data.Int+import           Data.Text                (Text)+import           GHC.Generics             (Generic)+import           Network.Run.TCP          (runTCPClient)+import           Network.Socket           as S+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck++import qualified Data.Text                as T++import           Pinch+import           Pinch.Arbitrary          ()+import           Pinch.Client+import           Pinch.Server+import           Pinch.Transport++echoServer :: ThriftServer+echoServer = createServer $ \_ -> Just $ CallHandler $ \_ (r :: Value TStruct) -> do+  pure r++data CalcRequest = CalcRequest+  { inp1 :: Field 1 Int32+  , inp2 :: Field 2 Int32+  , op   :: Field 3 Op+  } deriving (Generic, Show)+instance Pinchable CalcRequest++data Op = Plus (Enumeration 1) | Minus (Enumeration 2) | Div (Enumeration 3)+  deriving (Generic, Show)+instance Pinchable Op++data CalcResult = CalcResult+  { result   :: Field 1 (Maybe Int32)+  , errorMsg :: Field 2 (Maybe Text)+  } deriving (Generic, Show, Eq)+instance Pinchable CalcResult++calcServer :: ThriftServer+calcServer = createServer $ \_ -> Just $ CallHandler $ \_ (CalcRequest (Field inp1) (Field inp2) (Field op)) -> do+  let ret = case op of+        Plus _ -> CalcResult (Field $ Just $ inp1 + inp2) (Field Nothing)+        Minus _ -> CalcResult (Field $ Just $ inp1 - inp2) (Field Nothing)+        Div _ | inp2 == 0 -> CalcResult (Field Nothing) (Field $ Just "div by zero")+        Div _ -> CalcResult (Field $ Just $ inp1 `div` inp2) (Field Nothing)+  pure ret++onewayServer :: IO (ThriftServer, MVar (Value TStruct))+onewayServer = do+  ref <- newEmptyMVar+  let srv = createServer $ \_ -> Just $ OnewayHandler $ \_ (r :: Value TStruct) -> putMVar ref r+  pure (srv, ref)++errorServer :: ThriftServer+errorServer = createServer $ \nm -> case nm of+  "app_ex" -> Just $ CallHandler $ \_ (msg :: Value TStruct) ->+    throwIO $ ApplicationException "Test" InternalError :: IO (Value TStruct)+  "hs_ex" -> Just $ CallHandler $ \_ (_ :: Value TStruct) -> error "nononono" :: IO (Value TStruct)+  _ -> Nothing++spec :: Spec+spec = do+  describe "Client/Server" $ do+    prop "echo test" $ withMaxSuccess 10 $ \(request :: Value TStruct) -> ioProperty $+      withLoopbackServer echoServer $ \client -> do+        reply <- call client $ TCall "" request+        pure $+          reply === request++    it "calculator" $ do+      withLoopbackServer calcServer $ \client -> do+        r1 <- call client $ mkCall 10 20 Plus+        r1 `shouldBe` CalcResult (Field $ Just 30) (Field Nothing)++        r2 <- call client $ mkCall 10 20 Minus+        r2 `shouldBe` CalcResult (Field $ Just $ -10) (Field Nothing)++        r3 <- call client $ mkCall 20 10 Div+        r3 `shouldBe` CalcResult (Field $ Just 2) (Field Nothing)++        r4 <- call client $ mkCall 10 0 Div+        r4 `shouldBe` CalcResult (Field Nothing) (Field $ Just "div by zero")++    it "oneway" $ do+      (srv, ref) <- onewayServer+      withLoopbackServer srv $ \client -> do+        let val = struct [1 .= True, 2 .= ("Hello" :: Text)]+        _ <- call client $ TOneway "test" val+        r1 <- takeMVar ref+        r1 `shouldBe` val++        _ <- call client (TCall "test" val :: ThriftCall (Value TStruct)) `shouldThrow` \e ->+          case e of+            ApplicationException _ ty -> ty == InvalidMessageType+        pure ()++    it "multiplex" $ do+      let srv = multiplex [("calc", calcServer), ("echo", echoServer)]+      withLoopbackServer srv $ \client -> do+        r1 <- call (multiplexClient client "calc") $ mkCall 10 20 Plus+        r1 `shouldBe` CalcResult (Field $ Just 30) (Field Nothing)++        let payload = struct [1 .= True, 2 .= ("Hello" :: Text)]+        r2 <- call (multiplexClient client "echo") $ TCall "" payload+        r2 `shouldBe` payload++    it "exceptions" $ do+      withLoopbackServer errorServer $ \client -> do+        let val = struct [1 .= True, 2 .= ("Hello" :: Text)]+        _ <- call client (TCall "app_ex" val :: ThriftCall (Value TStruct)) `shouldThrow` \e ->+          case e of+            ApplicationException msg ty -> msg == "Test" && ty == InternalError++        _ <- call client (TCall "hs_ex" val :: ThriftCall (Value TStruct)) `shouldThrow` \e ->+          case e of+            ApplicationException msg ty -> "nonono" `T.isInfixOf` msg && ty == InternalError++        _ <- call client (TCall "missing" val :: ThriftCall (Value TStruct)) `shouldThrow` \e ->+          case e of+            ApplicationException msg ty -> ty == WrongMethodName+        pure ()++  where+    mkCall inp1 inp2 op = TCall "calc" $ pinch $ CalcRequest (Field inp1) (Field inp2) (Field $ op $ Enumeration)+++withLoopbackServer :: ThriftServer -> (Client -> IO a) -> IO a+withLoopbackServer srv cont = do+    addr <- resolve Stream (Just "127.0.0.1") "54093" True+    bracketOnError (open addr) close (\sock ->+      withAsync (loop sock `finally` close sock) $ \_ ->+        runTCPClient "127.0.0.1" "54093" $ \s -> do+          c <- client <$> createChannel s framedTransport binaryProtocol+          cont c+      )+  where+    open addr = bracketOnError (openServerSocket addr) close $ \sock -> do+        listen sock 1024+        return sock+    loop sock = forever $ bracketOnError (accept sock) (close . fst) $+        \(conn, _peer) ->+          void $ forkFinally (runServer conn) (const $ gracefulClose conn 5000)+    runServer sock = do+      createChannel sock framedTransport binaryProtocol+        >>= runConnection mempty srv++    resolve :: SocketType -> Maybe HostName -> S.ServiceName -> Bool -> IO AddrInfo+    resolve socketType mhost port passive =+        head <$> getAddrInfo (Just hints) mhost (Just port)+      where+        hints = defaultHints+          { addrSocketType = socketType+          , addrFlags = if passive then [AI_PASSIVE] else []+          }+    openServerSocket :: AddrInfo -> IO Socket+    openServerSocket addr = bracketOnError (openSocket addr) close $ \sock -> do+      setSocketOption sock ReuseAddr 1+      withFdSocket sock $ setCloseOnExecIfNeeded+      bind sock $ addrAddress addr+      return sock

@@ -10,67 +10,68 @@ import Test.Hspec.QuickCheck  import qualified Data.ByteString as B+import qualified Data.Serialize.IEEE754 as G+import qualified Data.Serialize.Get as G  import Pinch.Arbitrary  import qualified Pinch.Internal.Builder as BB-import qualified Pinch.Internal.Parser  as P  roundTrip     :: (Show a, Eq a)-    => P.Parser a -> (a -> BB.Builder) -> a -> Expectation+    => G.Get a -> (a -> BB.Builder) -> a -> Expectation roundTrip parser builder a =-        P.runParser parser (BB.runBuilder (builder a)) `shouldBe` Right a+        G.runGet parser (BB.runBuilder (builder a)) `shouldBe` Right a  spec :: Spec spec = describe "Builder and Parser" $ do      prop "can round trip 8-bit integers" $-        roundTrip P.int8 BB.int8+        roundTrip G.getInt8 BB.int8      prop "can round trip 16-bit integers" $-        roundTrip P.int16 BB.int16BE+        roundTrip G.getInt16be BB.int16BE      prop "can round trip 32-bit integers" $-        roundTrip P.int32 BB.int32BE+        roundTrip G.getInt32be BB.int32BE      prop "can round trip 64-bit integers" $-        roundTrip P.int64 BB.int64BE+        roundTrip G.getInt64be BB.int64BE      prop "can round trip 64-bit little endian integers" $-        roundTrip P.int64LE BB.int64LE+        roundTrip G.getInt64le BB.int64LE      prop "can round trip doubles" $-        roundTrip P.double BB.doubleBE+        roundTrip G.getFloat64be BB.doubleBE      prop "can round trip little endian doubles" $-        roundTrip P.doubleLE BB.doubleLE+        roundTrip G.getFloat64le BB.doubleLE      prop "can round trip bytestrings" $ \(SomeByteString bs) ->-        roundTrip (P.take (B.length bs)) BB.byteString bs+        roundTrip (G.getByteString (B.length bs)) BB.byteString bs      prop "can round trip primitive appends" $         roundTrip-            ((,) <$> P.int32 <*> P.int64)+            ((,) <$> G.getInt32be <*> G.getInt64be)             (\(a, b) -> BB.int32BE a <> BB.int64BE b)      prop "can round trip byteString appends" $         \(SomeByteString l) (SomeByteString r) ->             roundTrip-                ((,) <$> P.take (B.length l) <*> P.take (B.length r))+                ((,) <$> G.getByteString (B.length l) <*> G.getByteString (B.length r))                 (\(a, b) -> BB.byteString a <> BB.byteString b)                 (l, r)      prop "can round trip byteString-primitive appends" $         \(SomeByteString l) r ->             roundTrip-                ((,) <$> P.take (B.length l) <*> P.double)+                ((,) <$> G.getByteString (B.length l) <*> G.getFloat64be)                 (\(a, b) -> BB.byteString a <> BB.doubleBE b)                 (l, r)      prop "can round trip primitive-byteString appends" $         \l (SomeByteString r) ->             roundTrip-                ((,) <$> P.int64 <*> P.take (B.length r))+                ((,) <$> G.getInt64be <*> G.getByteString (B.length r))                 (\(a, b) -> BB.int64BE a <> BB.byteString b)                 (l, r)

@@ -1,144 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE NegativeLiterals  #-}-{-# LANGUAGE OverloadedStrings #-}-module Pinch.Internal.ParserSpec (spec) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif--import Data.Either           (isLeft)-import Data.Word             (Word8)-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck--import qualified Data.ByteString as B--import Pinch.Arbitrary--import qualified Pinch.Internal.Parser as P---parse :: [Word8] -> P.Parser a -> Either String a-parse s p = P.runParser p (B.pack s)---parseCases-    :: (Show a, Eq a)-    => P.Parser a -> [([Word8], a)] -> Expectation-parseCases parser = mapM_ . uncurry $ \bytes expected ->-    (bytes `parse` parser) `shouldBe` Right expected---spec :: Spec-spec = describe "Parser" $ do--    it "can succeed" $-        P.runParser (return 42) "" `shouldBe` Right (42 :: Int)--    it "can fail" $-        (P.runParser (fail "great sadness") "" :: Either String ())-            `shouldBe` Left "great sadness"--    it "can parse 8-bit integers" $-        parseCases P.int8-            [ ([0x01], 1)-            , ([0x05], 5)-            , ([0x7f], 127)-            , ([0xff], -1)-            , ([0x80], -128)-            ]--    it "can parse 16-bit integers" $-        parseCases P.int16-            [ ([0x00, 0x01], 1)-            , ([0x00, 0xff], 255)-            , ([0x01, 0x00], 256)-            , ([0x01, 0x01], 257)-            , ([0x7f, 0xff], 32767)-            , ([0xff, 0xff], -1)-            , ([0xff, 0xfe], -2)-            , ([0xff, 0x00], -256)-            , ([0xff, 0x01], -255)-            , ([0x80, 0x00], -32768)-            ]--    it "can parse 32-bit integers" $-        parseCases P.int32-            [ ([0x00, 0x00, 0x00, 0x01], 1)-            , ([0x00, 0x00, 0x00, 0xff], 255)-            , ([0x00, 0x00, 0xff, 0xff], 65535)-            , ([0x00, 0xff, 0xff, 0xff], 16777215)-            , ([0x7f, 0xff, 0xff, 0xff], 2147483647)-            , ([0xff, 0xff, 0xff, 0xff], -1)-            , ([0xff, 0xff, 0xff, 0x00], -256)-            , ([0xff, 0xff, 0x00, 0x00], -65536)-            , ([0xff, 0x00, 0x00, 0x00], -16777216)-            , ([0x80, 0x00, 0x00, 0x00], -2147483648)-            ]--    it "can parse 64-bit integers" $-        parseCases P.int64-            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1)-            , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295)-            , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775)-            , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 281474976710655)-            , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 72057594037927935)-            , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 9223372036854775807)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1)-            , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], -4294967296)-            , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], -1099511627776)-            , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -281474976710656)-            , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -72057594037927936)-            , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808)-            ]--    it "can parse 64-bit little endian integers" $-        parseCases P.int64LE-            [ ([0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1)-            , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], 4294967295)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00], 1099511627775)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x00], 281474976710655)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x00], 72057594037927935)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f], 9223372036854775807)-            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1)-            , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], -4294967296)-            , ([0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff], -1099511627776)-            , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0xff], -281474976710656)-            , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff], -72057594037927936)-            , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80], -9223372036854775808)-            ]--    it "can parse doubles" $-        parseCases P.double-            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0)-            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0)-            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001)-            , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], 1.1)-            , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], -1.1)-            , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], 3.141592653589793)-            , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001)-            ]--    it "can parse little endian doubles" $-        parseCases P.doubleLE-            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0)-            , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f], 1.0)-            , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0x3f], 1.0000000001)-            , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0x3f], 1.1)-            , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0xbf], -1.1)-            , ([0x18, 0x2d, 0x44, 0x54, 0xfb, 0x21, 0x09, 0x40], 3.141592653589793)-            , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0xbf], -1.0000000001)-            ]--    describe "take" $ do--        prop "returns the requested number of bytes" $-          \n (SomeByteString bs) ->-            B.length bs >= n ==>-              (B.length <$> P.runParser (P.take n) bs) === Right n--        prop "fails when input is too short" $-          \n (SomeByteString bs) ->-            B.length bs < n ==> isLeft (P.runParser (P.take n) bs)

@@ -82,7 +82,7 @@             Right v -> expectationFailure $               "Expected " ++ show bytes ++ " to fail to parse. " ++               "Got: " ++ show v-            Left msg -> msg `shouldContain` "Input is too short"+            Left msg -> msg `shouldContain` "too few bytes"   spec :: Spec@@ -273,7 +273,7 @@         , (SomeTType TList, [0x10, 0x00, 0x00, 0x00, 0x00])         ] -    it "can read and write messages" $ readWriteMessageCases+    it "can read and write messages" $ readMessageCases         [ ([ 0x00, 0x00, 0x00, 0x06                 -- length = 6            , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f     -- 'getFoo'            , 0x01                                   -- type = Call@@ -288,7 +288,7 @@            ], Message "setBar" Reply 1 (vstruct []))         ] -    it "can read strict messages" $ readMessageCases+    it "can read strict messages" $ readWriteMessageCases         [ ([ 0x80, 0x01     -- version = 1            , 0x00, 0x03     -- type = Exception 

@@ -77,7 +77,7 @@             Right v -> expectationFailure $               "Expected " ++ show bytes ++ " to fail to parse. " ++               "Got: " ++ show v-            Left msg -> msg `shouldContain` "Input is too short"+            Left msg -> msg `shouldContain` "too few bytes"   spec :: Spec

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Pinch.TransportSpec (spec) where++import Data.ByteString       (ByteString)+import Data.IORef            (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import qualified Data.ByteString as BS+import qualified Data.Serialize.Get as G++import Pinch.Arbitrary (SomeByteString(..))+import Pinch.Transport (Transport(..), framedTransport, unframedTransport, Connection(..), ReadResult(..))++import qualified Pinch.Internal.Builder as B++data MemoryConnection = MemoryConnection+  { contents :: IORef ByteString+  , maxChunkSize :: Int -- ^ how many bytes to maximally return for one cGetSome call+  }++newMemoryConnection :: Int -> IO MemoryConnection+newMemoryConnection ch = MemoryConnection <$> newIORef mempty <*> pure ch++mGetContents :: MemoryConnection -> IO ByteString+mGetContents = readIORef . contents++instance Connection MemoryConnection where+  cGetSome (MemoryConnection ref ch) n = do+    bytes <- readIORef ref+    let (left, right) = BS.splitAt (min ch n) bytes+    writeIORef ref right+    return left+  cPut (MemoryConnection ref _) newBytes = do+    modifyIORef ref (<> newBytes)++transportSpec :: (forall c . Connection c => c -> IO Transport) -> Spec+transportSpec t = do+  prop "can roundtrip bytestrings" $ \(Positive c, SomeByteString bytes) ->+    ioProperty $ do+      buf <- newMemoryConnection c+      transp <- t buf+      writeMessage transp (B.byteString bytes)+      actual <- readMessage transp (G.getBytes $ BS.length bytes)+      pure $ actual === RRSuccess bytes++  it "EOF handling" $ do+    buf <- newMemoryConnection 10+    transp <- t buf+    r <- readMessage transp (G.getInt8)+    r `shouldBe` RREOF+++spec :: Spec+spec = do+  describe "framedTransport" $ do+    transportSpec framedTransport+    +    it "read case" $ do+      let payload = BS.pack [0x01, 0x05, 0x01, 0x08, 0xFF]+      buf <- newMemoryConnection 1+      transp <- framedTransport buf+      cPut buf $ BS.pack [0x00, 0x00, 0x00, 0x05]+      cPut buf payload+      r <- readMessage transp (G.getBytes $ BS.length payload)+      r `shouldBe` RRSuccess payload++    it "write case" $ do+      let payload = BS.pack [0x01, 0x05, 0x01, 0x08, 0xFF]+      buf <- newMemoryConnection 1+      transp <- framedTransport buf+      writeMessage transp (B.byteString payload)+      actual <- mGetContents buf+      actual `shouldBe` (BS.pack [0x00, 0x00, 0x00, 0x05] <> payload)+++  describe "unframedTransport" $ do+    transportSpec unframedTransport++    prop "read cases" $ \(SomeByteString payload) ->+      ioProperty $ do+        buf <- newMemoryConnection 1+        transp <- unframedTransport buf+        cPut buf payload+        r <- readMessage transp (G.getBytes $ BS.length payload)+        pure $ r === RRSuccess payload++    prop "write cases" $ \(SomeByteString payload) ->+      ioProperty $ do+        buf <- newMemoryConnection 1+        transp <- unframedTransport buf+        writeMessage transp (B.byteString payload)+        actual <- mGetContents buf+        pure $ actual === payload