diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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. - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/ . diff --git a/examples/keyvalue/Client.hs b/examples/keyvalue/Client.hs --- a/examples/keyvalue/Client.hs +++ b/examples/keyvalue/Client.hs @@ -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 diff --git a/pinch.cabal b/pinch.cabal --- a/pinch.cabal +++ b/pinch.cabal @@ -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 diff --git a/src/Pinch.hs b/src/Pinch.hs --- a/src/Pinch.hs +++ b/src/Pinch.hs @@ -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 #-} ------------------------------------------------------------------------------ diff --git a/src/Pinch/Client.hs b/src/Pinch/Client.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Client.hs @@ -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 diff --git a/src/Pinch/Internal/Builder.hs b/src/Pinch/Internal/Builder.hs --- a/src/Pinch/Internal/Builder.hs +++ b/src/Pinch/Internal/Builder.hs @@ -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 diff --git a/src/Pinch/Internal/Exception.hs b/src/Pinch/Internal/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Internal/Exception.hs @@ -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 . +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 . +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 diff --git a/src/Pinch/Internal/FoldList.hs b/src/Pinch/Internal/FoldList.hs --- a/src/Pinch/Internal/FoldList.hs +++ b/src/Pinch/Internal/FoldList.hs @@ -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 diff --git a/src/Pinch/Internal/Generic.hs b/src/Pinch/Internal/Generic.hs --- a/src/Pinch/Internal/Generic.hs +++ b/src/Pinch/Internal/Generic.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Pinch/Internal/Parser.hs b/src/Pinch/Internal/Parser.hs deleted file mode 100644 --- a/src/Pinch/Internal/Parser.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} --- | --- Module : Pinch.Internal.Parser --- Copyright : (c) Abhinav Gupta 2015 --- License : BSD3 --- --- Maintainer : Abhinav Gupta --- 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 #-} diff --git a/src/Pinch/Internal/Pinchable.hs b/src/Pinch/Internal/Pinchable.hs --- a/src/Pinch/Internal/Pinchable.hs +++ b/src/Pinch/Internal/Pinchable.hs @@ -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 diff --git a/src/Pinch/Internal/Pinchable/Parser.hs b/src/Pinch/Internal/Pinchable/Parser.hs --- a/src/Pinch/Internal/Pinchable/Parser.hs +++ b/src/Pinch/Internal/Pinchable/Parser.hs @@ -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 #-} diff --git a/src/Pinch/Internal/RPC.hs b/src/Pinch/Internal/RPC.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Internal/RPC.hs @@ -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 () diff --git a/src/Pinch/Internal/Value.hs b/src/Pinch/Internal/Value.hs --- a/src/Pinch/Internal/Value.hs +++ b/src/Pinch/Internal/Value.hs @@ -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) diff --git a/src/Pinch/Protocol.hs b/src/Pinch/Protocol.hs --- a/src/Pinch/Protocol.hs +++ b/src/Pinch/Protocol.hs @@ -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 diff --git a/src/Pinch/Protocol/Binary.hs b/src/Pinch/Protocol/Binary.hs --- a/src/Pinch/Protocol/Binary.hs +++ b/src/Pinch/Protocol/Binary.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Pinch/Protocol/Compact.hs b/src/Pinch/Protocol/Compact.hs --- a/src/Pinch/Protocol/Compact.hs +++ b/src/Pinch/Protocol/Compact.hs @@ -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 diff --git a/src/Pinch/Server.hs b/src/Pinch/Server.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Server.hs @@ -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 + } diff --git a/src/Pinch/Transport.hs b/src/Pinch/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Transport.hs @@ -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 . +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 . +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' diff --git a/tests/Pinch/ClientServerSpec.hs b/tests/Pinch/ClientServerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/ClientServerSpec.hs @@ -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 diff --git a/tests/Pinch/Internal/BuilderParserSpec.hs b/tests/Pinch/Internal/BuilderParserSpec.hs --- a/tests/Pinch/Internal/BuilderParserSpec.hs +++ b/tests/Pinch/Internal/BuilderParserSpec.hs @@ -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) diff --git a/tests/Pinch/Internal/ParserSpec.hs b/tests/Pinch/Internal/ParserSpec.hs deleted file mode 100644 --- a/tests/Pinch/Internal/ParserSpec.hs +++ /dev/null @@ -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) diff --git a/tests/Pinch/Protocol/BinarySpec.hs b/tests/Pinch/Protocol/BinarySpec.hs --- a/tests/Pinch/Protocol/BinarySpec.hs +++ b/tests/Pinch/Protocol/BinarySpec.hs @@ -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 diff --git a/tests/Pinch/Protocol/CompactSpec.hs b/tests/Pinch/Protocol/CompactSpec.hs --- a/tests/Pinch/Protocol/CompactSpec.hs +++ b/tests/Pinch/Protocol/CompactSpec.hs @@ -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 diff --git a/tests/Pinch/TransportSpec.hs b/tests/Pinch/TransportSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/TransportSpec.hs @@ -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