pinch 0.2.0.0 → 0.2.0.1
raw patch · 32 files changed
+2836/−2728 lines, 32 filesdep −criteriondep ~QuickCheckdep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies removed: criterion
Dependency ranges changed: QuickCheck, base, bytestring, containers, deepseq, text, unordered-containers, vector
API changes (from Hackage documentation)
Files
- CHANGES.md +5/−0
- Pinch.hs +0/−518
- Pinch/Internal/Bits.hs +0/−46
- Pinch/Internal/Builder.hs +0/−127
- Pinch/Internal/FoldList.hs +0/−120
- Pinch/Internal/Generic.hs +0/−240
- Pinch/Internal/Message.hs +0/−75
- Pinch/Internal/Parser.hs +0/−175
- Pinch/Internal/Pinchable.hs +0/−345
- Pinch/Internal/Pinchable/Parser.hs +0/−91
- Pinch/Internal/TType.hs +0/−183
- Pinch/Internal/Value.hs +0/−203
- Pinch/Protocol.hs +0/−41
- Pinch/Protocol/Binary.hs +0/−351
- bench/Bench.hs +0/−104
- bench/pinch-bench/Bench.hs +189/−0
- bench/pinch-bench/pinch-bench.cabal +22/−0
- examples/keyvalue/keyvalue.cabal +3/−3
- pinch.cabal +102/−106
- src/Pinch.hs +518/−0
- src/Pinch/Internal/Bits.hs +46/−0
- src/Pinch/Internal/Builder.hs +127/−0
- src/Pinch/Internal/FoldList.hs +120/−0
- src/Pinch/Internal/Generic.hs +240/−0
- src/Pinch/Internal/Message.hs +75/−0
- src/Pinch/Internal/Parser.hs +175/−0
- src/Pinch/Internal/Pinchable.hs +345/−0
- src/Pinch/Internal/Pinchable/Parser.hs +91/−0
- src/Pinch/Internal/TType.hs +183/−0
- src/Pinch/Internal/Value.hs +203/−0
- src/Pinch/Protocol.hs +41/−0
- src/Pinch/Protocol/Binary.hs +351/−0
CHANGES.md view
@@ -1,3 +1,8 @@+0.2.0.1+=======++- Build with GHC 8.+ 0.2.0.0 =======
− Pinch.hs
@@ -1,518 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--- |--- Module : Pinch--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Pinch defines machinery to specify how types can be encoded into or decoded--- from Thrift payloads.----module Pinch- (-- -- * Serializing and deserializing-- -- $encodeDecodeValues-- encode- , decode-- -- * RPC-- -- $rpc-- , encodeMessage- , decodeMessage-- -- * Pinchable-- , Pinchable(..)- , Parser- , runParser-- -- ** Automatically deriving instances-- -- | Pinch supports deriving instances of 'Pinchable' automatically for- -- types that implement the @Generic@ typeclass provided that they follow- -- the outlined patterns in their constructors.-- -- *** Structs and exceptions- -- $genericStruct-- -- *** Unions- -- $genericUnion-- , Field(..)- , getField- , putField- , field-- , Void(..)-- -- *** Enums- -- $genericEnum-- , Enumeration(..)- , enum-- -- ** Manually writing instances-- -- | Instances of 'Pinchable' can be constructed by composing together- -- existing instances and using the '.=', '.:', etc. helpers.-- -- *** Structs and exceptions- -- $struct-- -- *** Unions- -- $union-- -- *** Enums- -- $enum-- -- ** Helpers-- -- *** @pinch@-- , (.=)- , (?=)- , struct- , union- , FieldPair-- -- *** @unpinch@-- , (.:)- , (.:?)-- -- * Value-- -- | 'Value' is an intermediate representation of Thrift payloads tagged- -- with TType tags. Types that want to be serialized into\/deserialized- -- from Thrift payloads need only define a way to convert themselves to- -- and from 'Value' objects via 'Pinchable'.-- , Value- , SomeValue(..)-- -- * Messages-- , Message- , mkMessage- , messageName- , messageType- , messageId- , getMessageBody-- , MessageType(..)-- -- * Protocols-- , Protocol- , binaryProtocol-- -- * TType-- -- | TType is used to refer to the Thrift protocol-level type of a value.-- , TType- , IsTType(..)-- -- ** Tags-- -- | TType tags allow writing code that depends on knowing the @TType@ of- -- values, or asserting conditions on it, at compile time.- --- -- For example, values in a map, list, or set must all have the same TType.- -- This is enforced at the type level by parameterizing 'Value' over these- -- tags.-- , TBool- , TByte- , TDouble- , TEnum- , TInt16- , TInt32- , TInt64- , TBinary- , TStruct- , TUnion- , TException- , TMap- , TSet- , TList- ) where--import Control.Monad-import Data.ByteString (ByteString)-import Data.Int (Int32)-import Data.Text (Text)--import Pinch.Internal.Builder (runBuilder)-import Pinch.Internal.Generic-import Pinch.Internal.Message-import Pinch.Internal.Pinchable-import Pinch.Internal.TType-import Pinch.Internal.Value-import Pinch.Protocol-import Pinch.Protocol.Binary------------------------------------------------------------------------------------ $encodeDecodeValues------ Types that can be serialized and deserialized into\/from Thrift values--- implement the 'Pinchable' typeclass. Instances may be derived automatically--- using generics, or written out by hand.------ The 'Pinchable' typeclass converts objects into and from 'Value' objects,--- which act as a direct mapping to the Thrift wire representation. A--- 'Protocol' is responsible for converting 'Value' objects to and from--- bytestrings.------ The 'encode' and 'decode' methods may be used on objects that implement the--- 'Pinchable' typeclass to get the wire representation directly.------ > +------------+ Pinchable Protocol +------------+--- > | | +------------+ | |--- > | +----pinch------> +---serialize---> |--- > | Your Type | | Value a | | ByteString |--- > | <---unpinch-----+ <--deserialize--+ |--- > | | +------------+ | |--- > | | | |--- > | +-------------------encode-------------------> |--- > | | | |--- > | <-------------------decode-------------------+ |--- > +------------+ +------------+---- | Encode the given 'Pinchable' value using the given 'Protocol'.------ >>> unpack $ encode binaryProtocol ["a" :: ByteString, "b"]--- [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]----encode :: Pinchable a => Protocol -> a -> ByteString-encode p = runBuilder . serializeValue p . pinch-{-# INLINE encode #-}---- | Decode a 'Pinchable' value from the using the given 'Protocol'.------ >>> let s = pack [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]--- >>> decode binaryProtocol s :: Either String [ByteString]--- Right ["a","b"]----decode :: Pinchable a => Protocol -> ByteString -> Either String a-decode p = deserializeValue p >=> runParser . unpinch-{-# INLINE decode #-}------------------------------------------------------------------------------------ $rpc------ Thrift requests implicitly form a struct and responses implicitly form a--- union. To send\/receive the request\/response, it must be wrapped inside a--- 'Message'. The 'Message' contains information like the method name, the--- message ID (to match out of order responses with requests), and whether--- it contains a request or a response.------ Requests and responses may be wrapped into @Message@ objects using the--- 'mkMessage' function. The message body can be retrieved back using the--- 'getMessageBody' function. The 'encodeMessage' and 'decodeMessage'--- functions may be used to encode and decode messages into\/from bytestrings.------ Consider the service method,------ > User getUser(1: string userName, 2: list<Attribute> attributes)--- > throws (1: UserDoesNotExist doesNotExist,--- > 2: InternalError internalError)------ The request and response for this method implictly take the form:------ > struct getUserRequest {--- > 1: string userName--- > 2: list<Attribute> attributes--- > }------ > union getUserResponse {--- > 0: User success--- > 1: UserDoesNotExist doesNotExist--- > 2: InternalError InternalError--- > }------ (Note that the field ID 0 is reserved for the return value of the method.)------ Given corresponding data types @GetUserRequest@ and @GetUserResponse@, the--- client can do something similar to,------ @--- let req = GetUserRequest "jsmith" []--- msg = 'mkMessage' "getUser" 'Call' 0 req--- response <- sendToServer ('encodeMessage' msg)--- case 'decodeMessage' response of--- Left err -> handleError err--- Right msg -> case 'getMessageBody' msg of--- Left err -> handleError err--- Right (res :: GetUserResponse) -> handleResponse res--- @------ Similarly, on the server side,------ @--- case decodeMessage request of--- Left err -> handleError err--- Right msg -> case 'messageName' msg of--- "getUser" -> case getMessageBody msg of--- Left err -> handleError err--- Right (req :: GetUserRequest) -> do--- let mid = 'messageId' msg--- res <- handleGetUser req--- return (mkMessage "getUser" 'Reply' mid res)--- -- Note that the response MUST contain the same--- -- message ID as its request.--- _ -> handleUnknownMethod--- @---- | Encode the 'Message' using the given 'Protocol'.------ @--- let request = GetUserRequest (putField "jsmith") (putField [])--- message = 'mkMessage' "getUser" Call 42 request--- in encodeMessage binaryProtocol message--- @----encodeMessage :: Protocol -> Message -> ByteString-encodeMessage p = runBuilder . serializeMessage p-{-# INLINE encodeMessage #-}---- | Decode a 'Message' using the given 'Protocol'.------ >>> decodeMessage binaryProtocol bs >>= getMessageBody :: Either String GetUserRequest--- Right (GetUserRequest {userName = Field "jsmith", userAttributes = Field []})----decodeMessage :: Protocol -> ByteString -> Either String Message-decodeMessage = deserializeMessage-{-# INLINE decodeMessage #-}---- | Build a @Message@.-mkMessage- :: (Pinchable a, Tag a ~ TStruct)- => Text- -- ^ Name of the target method.- -> MessageType- -- ^ Type of the message.- -> Int32- -- ^ Message ID.- -> a- -- ^ Message payload. This must be an object which serializes into a- -- struct.- -> Message-mkMessage name typ mid body = Message name typ mid (pinch body)-{-# INLINE mkMessage #-}---- | Read the message contents.------ This returns a @Left@ result if the message contents do not match the--- requested type.-getMessageBody- :: (Pinchable a, Tag a ~ TStruct) => Message -> Either String a-getMessageBody = runParser . unpinch . messagePayload-{-# INLINE getMessageBody #-}------------------------------------------------------------------------------------ $genericStruct------ Given the struct,------ > struct User {--- > 1: required string name--- > 2: optional string emailAddress--- > }------ A @Pinchable@ instance for it can be automatically derived by wrapping--- fields of the data type with the 'Field' type and specifying the field--- identifier as a type-level numeral. Fields which hold a @Maybe@ value are--- considered optional.------ @--- data User = User--- { userName :: 'Field' 1 Text--- , userEmailAddress :: Field 2 (Maybe Text)--- }--- deriving (Generic)------ instance Pinchable User--- @------ The @DeriveGeneric@ extension is required to automatically derive instances--- of the @Generic@ typeclass and the @DataKinds@ extension is required to use--- type-level numerals.------------------------------------------------------------------------------------ $genericUnion------ As with structs and exceptions, fields of the data type representing a--- union must be tagged with 'Field', but to satisfy the property of a union--- that only one value is set at a time, they must be on separate--- constructors.------ For example, given the union,------ > union Item {--- > 1: binary bin--- > 2: string str--- > 3: i32 int--- > }------ A @Pinchable@ instance can be derived like so,------ > data Item--- > = ItemBin (Field 1 ByteString)--- > | ItemStr (Field 2 Text)--- > | ItemInt (Field 3 Int32)--- > deriving (Generic)--- >--- > instance Pinchable Item------ The @DeriveGeneric@ extension is required to automatically derive instances--- of the @Generic@ typeclass and the @DataKinds@ extension is required to use--- type-level numerals.------ If the union represents the response of a service method which returns a--- @void@ result, the type 'Void' may be used.------ @--- data GetFooResponse--- = GetFooDoesNotExist (Field 1 FooDoesNotExist)--- | GetFooInternalError (Field 2 InternalError)--- | GetFooSuccess 'Void'--- @------------------------------------------------------------------------------------ $genericEnum------ Given the enum,------ > enum Op {--- > Add, Sub, Mul, Div--- > }------ A @Pinchable@ instance can be derived for it by creating one constructor--- for each of the enum values and providing it a single 'Enumeration'--- argument tagged with the enum value.------ @--- data Op--- = OpAdd ('Enumeration' 0)--- | OpSub (Enumeration 1)--- | OpMul (Enumeration 2)--- | OpDiv (Enumeration 3)--- deriving (Generic)------ instance Pinchable Op--- @------ Note that you need to know the values assigned to the enums. If not--- specified, Thrift automatically assigns incrementing values to the items in--- the order they appear starting at 0.------ The @DeriveGeneric@ extension is required to automatically derive instances--- of the @Generic@ typeclass and the @DataKinds@ extension is required to use--- type-level numerals.------------------------------------------------------------------------------------ $struct------ Given a Thrift struct,------ > struct Post {--- > 1: optional string subject--- > 2: required string body--- > }------ The 'Pinchable' instance for it will be,------ @--- data Post = Post--- { postSubject :: Maybe Text--- , postBody :: Text--- }------ instance 'Pinchable' Post where--- type 'Tag' Post = 'TStruct'------ pinch (Post subject body) =--- 'struct' [ 1 '?=' subject--- , 2 '.=' body--- ]------ unpinch value =--- Post \<$\> value '.:?' 1--- \<*\> value '.:' 2--- @--------------------------------------------------------------------------------------- $union------ Given a Thrift union,------ > union PostBody {--- > 1: string markdown--- > 2: binary rtf--- > }------ The 'Pinchable' instance for it will be,------ @--- data PostBody--- = PostBodyMarkdown Text--- | PostBodyRtf ByteString------ instance Pinchable PostBody where--- type Tag PostBody = 'TUnion'------ pinch (PostBodyMarkdown markdownBody) =--- 'union' 1 markdownBody--- pinch (PostBodyRtf rtfBody) =--- union 2 rtfBody------ unpinch v = PostBodyMarkdown \<$\> v .: 1--- \<|\> PostBodyRtf \<$\> v .: 2--- @------------------------------------------------------------------------------------ $enum------ Given an enum,------ > enum Role {--- > DISABLED = 0,--- > USER,--- > ADMIN,--- > }------ The 'Pinchable' instance for it will be,------ > data Role = RoleDisabled | RoleUser | RoleAdmin--- >--- > instance Pinchable Role where--- > type Tag Role = TEnum--- >--- > pinch RoleDisabled = pinch (0 :: Int32)--- > pinch RoleUser = pinch (1 :: Int32)--- > pinch RoleAdmin = pinch (2 :: Int32)--- >--- > unpinch v = do--- > value <- unpinch v--- > case (value :: Int32) of--- > 0 -> Right RoleDisabled--- > 1 -> Right RoleUser--- > 2 -> Right RoleAdmin--- > _ -> Left $ "Unknown role: " ++ show value
− Pinch/Internal/Bits.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}--- |--- Module : Pinch.Internal.Bits--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Provides unchecked bitwise shift operations. Similar versions of @shiftR@--- are used by @ByteString.Builder.Prim@.-module Pinch.Internal.Bits- ( w16ShiftL- , w32ShiftL- , w64ShiftL- ) where--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-import GHC.Base (Int (..), uncheckedShiftL#)-import GHC.Word (Word16 (..), Word32 (..), Word64 (..))-#else-import Data.Bits (shiftL)-import Data.Word (Word16, Word32, Word64)-#endif--{-# INLINE w16ShiftL #-}-w16ShiftL :: Word16 -> Int -> Word16--{-# INLINE w32ShiftL #-}-w32ShiftL :: Word32 -> Int -> Word32--{-# INLINE w64ShiftL #-}-w64ShiftL :: Word64 -> Int -> Word64---- If we're not on GHC, the regular shiftL will be returned.--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-w16ShiftL (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)-w32ShiftL (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)-w64ShiftL (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)-#else-w16ShiftL = shiftL-w32ShiftL = shiftL-w64ShiftL = shiftL-#endif
− Pinch/Internal/Builder.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Pinch.Internal.Builder--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ This module implements a ByteString builder very similar to--- 'Data.ByteString.Builder' except that it keeps track of its final serialized--- length. This allows it to allocate the target ByteString in one @malloc@ and--- simply write the bytes to it.-module Pinch.Internal.Builder- ( Builder- , runBuilder-- , append- , int8- , int16BE- , int32BE- , int64BE- , doubleBE- , byteString- ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Monoid-#endif--import Data.ByteString (ByteString)-import Data.ByteString.Builder.Prim ((>*<))-import Data.Int-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr)--import qualified Data.ByteString.Builder.Prim as BP-import qualified Data.ByteString.Builder.Prim.Internal as BPI-import qualified Data.ByteString.Internal as BI---- | A ByteString Builder that knows its final size.-data Builder = B {-# UNPACK #-} !Int (Ptr Word8 -> IO ())---- | Build a ByteString from the given ByteString builder.-runBuilder :: Builder -> ByteString-runBuilder (B size fill) = BI.unsafeCreate size fill-{-# INLINE runBuilder #-}---- | Append two Builders into one.-append :: Builder -> Builder -> Builder-append (B ll lf) (B rl rf) = B (ll + rl) (\p -> lf p >> rf (p `plusPtr` ll))-{-# INLINE [1] append #-}- -- Don't inline append until phase 1. This ensures that the- -- append/primFixed* rules have a chance to fire.--instance Monoid Builder where- {-# INLINE mempty #-}- mempty = B 0 (\_ -> return ())-- {-# INLINE mappend #-}- mappend = append-- {-# INLINE mconcat #-}- mconcat = foldr mappend mempty--primFixed :: BP.FixedPrim a -> a -> Builder-primFixed prim a = B (BPI.size prim) (BPI.runF prim a)-{-# INLINE [1] primFixed #-}- -- Don't inline append until phase 1. This ensures that the- -- append/primFixed* rules have a chance to fire.---- The following rules try to join together instances of primFixed that are--- being appended together. These were adapted almost as-is from--- ByteString.Builder.Prim's rules around this.--{-# RULES--"append/primFixed" forall p1 p2 v1 v2.- append (primFixed p1 v1) (primFixed p2 v2) =- primFixed (p1 >*< p2) (v1, v2)--"append/primFixed/rightAssociative" forall p1 p2 v1 v2 b.- append (primFixed p1 v1) (append (primFixed p2 v2) b) =- append (primFixed (p1 >*< p2) (v1, v2)) b--"append/primFixed/leftAssociative" forall p1 p2 v1 v2 b.- append (append b (primFixed p1 v1)) (primFixed p2 v2) =- append b (primFixed (p1 >*< p2) (v1, v2))-- #-}---- | Serialize a single signed byte.-int8 :: Int8 -> Builder-int8 = primFixed BP.int8-{-# INLINE int8 #-}---- | Serialize a signed 16-bit integer in big endian format.-int16BE :: Int16 -> Builder-int16BE = primFixed BP.int16BE-{-# INLINE int16BE #-}---- | Serialize a signed 32-bit integer in big endian format.-int32BE :: Int32 -> Builder-int32BE = primFixed BP.int32BE-{-# INLINE int32BE #-}---- | Serialize a signed 64-bit integer in big endian format.-int64BE :: Int64 -> Builder-int64BE = primFixed BP.int64BE-{-# INLINE int64BE #-}---- | Serialize a signed 64-bit floating point number in big endian format.-doubleBE :: Double -> Builder-doubleBE = primFixed BP.doubleBE-{-# INLINE doubleBE #-}---- | Inlcude the given ByteString as-is in the builder.------ Note that because this operation is applied lazily, we will maintain a--- reference to the ByteString until the builder is executed.-byteString :: ByteString -> Builder-byteString (BI.PS fp off len) =- B len $ \dst ->- withForeignPtr fp $ \src ->- BI.memcpy dst (src `plusPtr` off) len-{-# INLINE byteString #-}
− Pinch/Internal/FoldList.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module : Pinch.Internal.FoldList--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Implements a representation of a list as a fold over it.-module Pinch.Internal.FoldList- ( FoldList- , map- , replicate- , replicateM- , F.foldl'- , F.foldr- , F.toList- , fromFoldable- , fromMap- , T.mapM- , T.sequence- ) where--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.Monoid-import Data.Typeable (Typeable)--import qualified Control.Monad as M-import qualified Data.Foldable as F-import qualified Data.List as L-import qualified Data.Traversable as T---- | FoldList represents a list as a @foldl'@ traversal over it.------ This allows us to avoid allocating new collections for an intermediate--- representation of various data types that users provide.-newtype FoldList a = FoldList (forall r. (r -> a -> r) -> r -> r)- deriving Typeable---- | Builds a FoldList over pairs of items of a map.-fromMap- :: (forall r. (r -> k -> v -> r) -> r -> m k v -> r)- -- ^ @foldlWithKey@ provided by the map implementation.- -> m k v- -> FoldList (k, v)-fromMap foldlWithKey m = FoldList (\k r -> foldlWithKey (go k) r m)- where- go k r a b = k r (a, b)- {-# INLINE go #-}-{-# INLINE fromMap #-}---- | Builds a FoldList from a Foldable.-fromFoldable :: F.Foldable f => f a -> FoldList a-fromFoldable l = FoldList (\k r -> F.foldl' k r l)-{-# INLINE fromFoldable #-}---- | Applies the given function to all elements in the FoldList.------ Note that the function is applied lazily when the results are requested. If--- the results of the same FoldList are requested multiple times, the function--- will be called multiple times on the same elements.-map :: (a -> b) -> FoldList a -> FoldList b-map f (FoldList l) = FoldList $ \k r0 -> l (\r1 a -> k r1 (f a)) r0-{-# INLINE map #-}---- | Returns a FoldList with the given item repeated @n@ times.-replicate :: Int -> a -> FoldList a-replicate n a = fromFoldable (L.replicate n a)-{-# INLINE replicate #-}---- | Executes the given monadic action the given number of times and returns--- a FoldList of the results.-replicateM :: Monad m => Int -> m a -> m (FoldList a)-replicateM n = M.liftM fromFoldable . M.replicateM n-{-# INLINE replicateM #-}--instance Show a => Show (FoldList a) where- show l = "[" ++ intercalate ", " (F.foldr go [] l) ++ "]"- where- go a xs = show a:xs--instance Functor FoldList where- fmap = map- {-# INLINE fmap #-}--instance F.Foldable FoldList where- foldMap f (FoldList l) = l (\r a -> r <> f a) mempty- {-# INLINE foldMap #-}-- foldl' f r (FoldList l) = l f r- {-# INLINE foldl' #-}--instance T.Traversable FoldList where- sequenceA (FoldList f) =- f (\l a -> go <$> l <*> a) (pure (FoldList (\_ r -> r)))- where- go (FoldList xs) x = FoldList (\k r -> k (xs k r) x)- {-# INLINE go #-}- {-# INLINE sequenceA #-}--instance Eq a => Eq (FoldList a) where- l == r = F.toList l == F.toList r--instance NFData a => NFData (FoldList a) where- rnf (FoldList l) = l (\() a -> rnf a `seq` ()) ()--instance Hashable a => Hashable (FoldList a) where- hashWithSalt s (FoldList l) = l hashWithSalt s
− Pinch/Internal/Generic.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# 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--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Implements support for automatically deriving Pinchable instances for types--- that implement @Generic@ and follow a specific pattern.----module Pinch.Internal.Generic- ( Field(..)- , getField- , putField- , field-- , Enumeration(..)- , enum-- , Void(..)- ) where---#if __GLASGOW_HASKELL__ < 709-import Data.Foldable (Foldable)-import Data.Monoid (Monoid)-import Data.Traversable (Traversable)-#endif--import Control.Applicative-import Control.DeepSeq (NFData)-import Data.Proxy (Proxy (..))-import Data.Typeable (Typeable)-import GHC.Generics-import GHC.TypeLits--import qualified Data.HashMap.Strict as HM--import Pinch.Internal.Pinchable-import Pinch.Internal.TType-import Pinch.Internal.Value (Value (..))----- | Implemented by TType tags whose values know how to combine.-class Combinable t where- combine :: Value t -> Value t -> Value t--instance Combinable TStruct where- combine (VStruct as) (VStruct bs) = VStruct $ as `HM.union` bs---instance OVERLAP GPinchable a => GPinchable (M1 i c a) where- type GTag (M1 i c a) = GTag a- gPinch = gPinch . unM1- gUnpinch = fmap M1 . gUnpinch----- Adds the name of the data type to the error message.-instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where- type GTag (D1 d a) = GTag a- gPinch = gPinch . unM1- gUnpinch v =- parserCatch (gUnpinch v)- (\msg -> fail $ "Failed to read '" ++ name ++ "': " ++ msg)- (return . M1)- where- name = datatypeName (undefined :: D1 d a b)--instance- ( GPinchable a- , GPinchable b- , GTag a ~ GTag b- , Combinable (GTag a)- ) => GPinchable (a :*: b) where- type GTag (a :*: b) = GTag a- gPinch (a :*: b) = gPinch a `combine` gPinch b- gUnpinch m = (:*:) <$> gUnpinch m <*> gUnpinch m--instance- ( GPinchable a- , GPinchable b- , GTag a ~ GTag b- ) => GPinchable (a :+: b) where- type GTag (a :+: b) = GTag a- gPinch (L1 a) = gPinch a- gPinch (R1 b) = gPinch b- gUnpinch m = L1 <$> gUnpinch m <|> R1 <$> gUnpinch m------------------------------------------------------------------------------------ | Fields of data types that represent structs, unions, and exceptions--- should be wrapped inside 'Field' and tagged with the field identifier.------ > data Foo = Foo (Field 1 Text) (Field 2 (Maybe Int32)) deriving Generic--- > instance Pinchable Foo------ > data A = A (Field 1 Int32) | B (Field 2 Text) deriving Generic--- > instance Pinchable Foo------ Fields which hold @Maybe@ values are treated as optional. All fields values--- must be 'Pinchable' to automatically derive a @Pinchable@ instance for the--- new data type.-newtype Field (n :: Nat) a = Field a- deriving- (Bounded, Eq, Enum, Foldable, Functor, Generic, Monoid, NFData, Ord, Show,- Traversable, Typeable)---- | Gets the current value of a field.------ > let Foo a' _ = {- ... -}--- > a = getField a'-getField :: Field n a -> a-getField (Field a) = a---- | Puts a value inside a field.------ > Foo (putField "Hello") (putField (Just 42))-putField :: a -> Field n a-putField = Field---- | A lens on @Field@ wrappers for use with the lens library.------ > person & name . field .~ "new value"----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)- => GPinchable (K1 i (Field n a)) where- type GTag (K1 i (Field n a)) = TStruct- gPinch (K1 (Field a)) = struct [n .= a]- where- n = fromIntegral $ natVal (Proxy :: Proxy n)-- gUnpinch m = K1 . Field <$> m .: n- where- n = fromIntegral $ natVal (Proxy :: Proxy n)--instance- (Pinchable a, KnownNat n)- => GPinchable (K1 i (Field n (Maybe a))) where- type GTag (K1 i (Field n (Maybe a))) = TStruct- gPinch (K1 (Field a)) = struct [n ?= a]- where- n = fromIntegral $ natVal (Proxy :: Proxy n)-- gUnpinch m = K1 . Field <$> m .:? n- where- n = fromIntegral $ natVal (Proxy :: Proxy n)------------------------------------------------------------------------------------ | Data types that represent Thrift enums must have one constructor for each--- enum item accepting an 'Enumeration' object tagged with the corresponding--- enum value.------ > data Role = RoleUser (Enumeration 1) | RoleAdmin (Enumeration 2)--- > deriving Generic--- > instance Pinchable Role-data Enumeration (n :: Nat) = Enumeration- deriving- (Eq, Generic, Ord, Show, Typeable)--instance NFData (Enumeration n)---- | Convenience function to construct 'Enumeration' objects.------ > let role = RoleUser enum-enum :: Enumeration n-enum = Enumeration--instance KnownNat n => GPinchable (K1 i (Enumeration n)) where- type GTag (K1 i (Enumeration n)) = TEnum- gPinch (K1 Enumeration) = VInt32 . fromIntegral $ natVal (Proxy :: Proxy n)- gUnpinch (VInt32 i)- | i == val = return (K1 Enumeration)- | 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------------------------------------------------------------------------------------ | Represents a @void@ result for methods.------ This should be used as an element in a response union along with 'Field'--- tags.------ For a method,------ > void setValue(..) throws--- > (1: ValueAlreadyExists alreadyExists,--- > 2: InternalError internalError)------ Something similar to the following can be used.------ > data SetValueResponse--- > = SetValueAlreadyExists (Field 1 ValueAlreadyExists)--- > | SetValueInternalError (Field 2 InternalError)--- > | SetValueSuccess Void--- > deriving (Generic)--- >--- > instance Pinchable SetValueResponse-data Void = Void- deriving- (Eq, Generic, Ord, Show, Typeable)--instance GPinchable (K1 i Void) where- type GTag (K1 i Void) = TStruct-- gPinch (K1 Void) = struct []-- -- If the map isn't empty, there's probably an exception in there.- gUnpinch (VStruct m) | HM.null m = return $ K1 Void- gUnpinch x = fail $- "Failed to read response. Expected void, got: " ++ show x
− Pinch/Internal/Message.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--- |--- Module : Pinch.Internal.Message--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Message wrapper for Thrift payloads. Normal Thrift requests sent over the--- wire are wrapped inside a message envelope that contains information about--- the method being called, the type of message, etc. This information is--- essential for the RPC system to function.-module Pinch.Internal.Message- ( Message(..)- , MessageType(..)- ) where--import Control.DeepSeq (NFData)-import Data.Data (Data)-import Data.Int (Int32)-import Data.Text (Text)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)--import Pinch.Internal.TType (TStruct)-import Pinch.Internal.Value (Value)---- | Type of message being sent.-data MessageType- = Call- -- ^ A call to a specific method.- --- -- The message body is the request arguments struct.- | Reply- -- ^ Response to a call.- --- -- The message body is the response union.- | Exception- -- ^ Failure to make a call.- --- -- Note: This message type is /not/ used for exceptions that are defined- -- under the @throws@ clause of a method. Those exceptions are part of the- -- response union of the method and are received in a @Reply@. This- -- message type is used for Thrift-level failures.- | Oneway- -- ^ One-way call that expects no response.- deriving (Show, Eq, Data, Typeable, Generic)--instance NFData MessageType----- | Message envelope for Thrift payloads.-data Message = Message- { messageName :: !Text- -- ^ Name of the method to which this message is targeted.- , messageType :: !MessageType- -- ^ Type of the message.- , messageId :: !Int32- -- ^ Sequence ID of the message.- --- -- If the clients expect to receive out-of-order responses, they may use- -- the message ID to map responses back to their corresponding requests.- -- If the client does not expect out-of-order responses, they are free to- -- use the same message ID for all messages.- --- -- The server's contract regarding message IDs is that all responses must- -- have the same message ID as their corresponding requests.- , messagePayload :: !(Value TStruct)- -- ^ Contents of the message.- }- deriving (Show, Eq, Typeable, Generic)--instance NFData Message
− Pinch/Internal/Parser.hs
@@ -1,175 +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-- , int8- , int16- , int32- , int64- , double- , 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 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 #-}----- | @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 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 64-bit floating point number and advances the parser.-double :: Parser Double-double = int64 >>= \i -> return (ST.runST (cast i))-{-# INLINE double #-}---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 #-}
− Pinch/Internal/Pinchable.hs
@@ -1,345 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--- |--- Module : Pinch.Internal.Pinchable--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Provides the core @Pinchable@ typeclass and the @GPinchable@ typeclass used--- to derive instances automatically.----module Pinch.Internal.Pinchable- ( Pinchable(..)-- , (.=)- , (?=)- , struct- , union- , FieldPair-- , (.:)- , (.:?)-- , GPinchable(..)- , genericPinch- , genericUnpinch-- , Parser- , runParser- , 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)-import Data.List (foldl')-import Data.Text (Text)-import Data.Typeable ((:~:) (..))-import Data.Vector (Vector)-import GHC.Generics (Generic, Rep)--import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.Map.Strict as M-import qualified Data.Set as S-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE-import qualified Data.Vector as V-import qualified GHC.Generics as G--import Pinch.Internal.Pinchable.Parser-import Pinch.Internal.TType-import Pinch.Internal.Value--import qualified Pinch.Internal.FoldList as FL---- | Implementation of 'pinch' based on 'GPinchable'.-genericPinch- :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a))-genericPinch = gPinch . G.from---- | Implementation of 'unpinch' based on 'GPinchable'.-genericUnpinch- :: (Generic a, GPinchable (Rep a)) => Value (GTag (Rep a)) -> Parser a-genericUnpinch = fmap G.to . gUnpinch----- | GPinchable is used to impelment support for automatically deriving--- instances of Pinchable via generics.-class IsTType (GTag f) => GPinchable (f :: * -> *) where- -- | 'TType' tag to use for objects of this type.- type GTag f-- -- | Converts a generic representation of a value into a 'Value'.- gPinch :: f a -> Value (GTag f)-- -- | Converts a 'Value' back into the generic representation of the- -- object.- gUnpinch :: Value (GTag f) -> Parser (f a)----- | The Pinchable type class is implemented by types that can be sent or--- received over the wire as Thrift payloads.-class IsTType (Tag a) => Pinchable a where- -- | 'TType' tag for this type.- --- -- For most custom types, this will be 'TStruct', 'TUnion', or- -- 'TException'. For enums, it will be 'TEnum'. If the instance- -- automatically derived with use of @Generic@, this is not required- -- because it is automatically determined by use of @Field@ or- -- @Enumeration@.- type Tag a- type Tag a = GTag (Rep a)-- -- | Convert an @a@ into a 'Value'.- --- -- For structs, 'struct', '.=', and '?=' may be used to construct- -- 'Value' objects tagged with 'TStruct'.- pinch :: a -> Value (Tag a)-- -- | Read a 'Value' back into an @a@.- --- -- For structs, '.:' and '.:?' may be used to retrieve field values.- unpinch :: Value (Tag a) -> Parser a-- default pinch- :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a))- pinch = genericPinch-- default unpinch- :: (Generic a, GPinchable (Rep a))- => Value (GTag (Rep a)) -> Parser a- unpinch = genericUnpinch------------------------------------------------------------------------------------- | A pair of field identifier and maybe a value stored in the field. If the--- value is absent, the field will be ignored.-type FieldPair = (Int16, Maybe SomeValue)---- | Construct a 'FieldPair' from a field identifier and a 'Pinchable' value.-(.=) :: Pinchable a => Int16 -> a -> FieldPair-fid .= value = (fid, Just $ SomeValue (pinch value))---- | Construct a 'FieldPair' from a field identifier and an optional--- 'Pinchable' value.-(?=) :: Pinchable a => Int16 -> Maybe a -> FieldPair-fid ?= value = (fid, SomeValue . pinch <$> value)---- | Construct a 'Value' tagged with a 'TStruct' from the given key-value--- pairs. Optional fields whose values were omitted will be ignored.------ > struct [1 .= ("Hello" :: Text), 2 .= (42 :: Int16)]-struct :: [FieldPair] -> Value TStruct-struct = VStruct . foldl' go HM.empty- where- go m (_, Nothing) = m- go m (k, Just v) = HM.insert k v m---- | Constructs a 'Value' tagged with 'TUnion'.------ > union 1 ("foo" :: ByteString)----union :: Pinchable a => Int16 -> a -> Value TUnion-union k v = VStruct (HM.singleton k (SomeValue $ pinch v))---- | Given a field ID and a @Value TStruct@, get the value stored in the--- struct under that field ID. The lookup fails if the field is absent or if--- it's not the same type as expected by this call's context.-(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser a-(VStruct items) .: fieldId = do- SomeValue someValue <- note ("Field " ++ show fieldId ++ " is absent.")- $ fieldId `HM.lookup` items- (value :: Value (Tag a)) <-- note ("Field " ++ show fieldId ++ " has the incorrect type. " ++- "Expected '" ++ show (ttype :: TType (Tag a)) ++ "' but " ++- "got '" ++ show (valueTType someValue) ++ "'")- $ castValue someValue- unpinch value- where- note msg m = case m of- Nothing -> fail msg- Just v -> return v---- | Given a field ID and a @Value TStruct@, get the optional value stored in--- the struct under the given field ID. The value returned is @Nothing@ if it--- was absent or the wrong type. The lookup fails only if the value retrieved--- fails to 'unpinch'.-(.:?) :: forall a. Pinchable a- => Value TStruct -> Int16 -> Parser (Maybe a)-(VStruct items) .:? fieldId =- case value of- Nothing -> return Nothing- Just v -> Just <$> unpinch v- where- value :: Maybe (Value (Tag a))- value = fieldId `HM.lookup` items >>= \(SomeValue v) -> castValue v------------------------------------------------------------------------------------ | Helper to 'unpinch' values by matching TTypes.-checkedUnpinch- :: forall a b. (Pinchable a, IsTType b)- => Value b -> Parser a-checkedUnpinch = case ttypeEqT of- Nothing -> const . fail $- "Type mismatch. Expected " ++ show ttypeA ++ ". Got " ++ show ttypeB- Just (Refl :: Tag a :~: b) -> unpinch- where- ttypeA = ttype :: TType (Tag a)- ttypeB = ttype :: TType b---- | Helper to 'pinch' maps.-pinchMap- :: (Pinchable k, Pinchable v)- => (forall r. (r -> k -> v -> r) -> r -> m k v -> r)- -- ^ @foldlWithKey@- -> m k v- -> Value TMap-pinchMap foldlWithKey = VMap . FL.map go . FL.fromMap foldlWithKey- where- go (!k, !v) = MapItem (pinch k) (pinch v)--unpinchMap- :: (Pinchable k, Pinchable v)- => (k -> v -> m -> m) -> m -> Value a -> Parser m-unpinchMap mapInsert mapEmpty (VMap xs) =- FL.foldl' (\m (!k, !v) -> mapInsert k v m) mapEmpty <$> FL.mapM go xs- where- go (MapItem k v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v-unpinchMap _ _ x = fail $ "Failed to read map. Got " ++ show x--instance IsTType a => Pinchable (Value a) where- type Tag (Value a) = a- pinch = id- unpinch = return--instance Pinchable ByteString where- 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-- pinch = VList . FL.map pinch . FL.fromFoldable-- 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-- 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- , Hashable k- , Pinchable k- , Pinchable v- ) => Pinchable (HM.HashMap k v) where- type Tag (HM.HashMap k v) = TMap- pinch = pinchMap HM.foldlWithKey'- unpinch = unpinchMap HM.insert HM.empty--instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where- type Tag (M.Map k v) = TMap- pinch = pinchMap M.foldlWithKey'- unpinch = unpinchMap M.insert M.empty--instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where- type Tag (HS.HashSet a) = TSet- pinch = VSet . FL.map pinch . FL.fromFoldable-- 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- pinch = VSet . FL.map pinch . FL.fromFoldable-- 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
− Pinch/Internal/Pinchable/Parser.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE Rank2Types #-}--- |--- Module : Pinch.Internal.Pinchable.Parser--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Implements a continuation based version of the @Either e@ monad.----module Pinch.Internal.Pinchable.Parser- ( Parser- , runParser- , parserCatch- ) where--import Control.Applicative-import Control.Monad---- | Failure continuation. Called with the failure message.-type Failure r = String -> r-type Success a r = a -> r--- ^ Success continuation. Called with the result.---- | A simple continuation-based parser.------ This is just @Either e a@ in continuation-passing style.-newtype Parser a = Parser- { unParser :: forall r.- Failure r -- Failure continuation- -> Success a r -- Success continuation- -> r- } -- TODO can probably track position in the struct--instance Functor Parser where- {-# INLINE fmap #-}- fmap f (Parser g) = Parser $ \kFail kSucc -> g kFail (kSucc . f)--instance Applicative Parser where- {-# INLINE pure #-}- pure a = Parser $ \_ kSucc -> kSucc a-- {-# INLINE (<*>) #-}- Parser f' <*> Parser a' =- Parser $ \kFail kSuccB ->- f' kFail $ \f ->- a' kFail $ \a ->- kSuccB (f a)--instance Alternative Parser where- {-# INLINE empty #-}- empty = Parser $ \kFail _ -> kFail "Alternative.empty"-- {-# INLINE (<|>) #-}- Parser l' <|> Parser r' =- Parser $ \kFail kSucc ->- l' (\_ -> r' kFail kSucc) kSucc--instance Monad Parser where- {-# INLINE fail #-}- fail msg = Parser $ \kFail _ -> kFail msg-- {-# INLINE return #-}- return = pure-- {-# INLINE (>>) #-}- (>>) = (*>)-- {-# INLINE (>>=) #-}- Parser a' >>= k =- Parser $ \kFail kSuccB ->- a' kFail $ \a ->- unParser (k a) kFail kSuccB--instance MonadPlus Parser where- {-# INLINE mzero #-}- mzero = empty-- {-# INLINE mplus #-}- mplus = (<|>)---- | Run a @Parser@ and return the result inside an @Either@.-runParser :: Parser a -> Either String a-runParser p = unParser p Left Right---- | Allows handling parse errors.-parserCatch- :: Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b-parserCatch = unParser-{-# INLINE parserCatch #-}
− Pinch/Internal/TType.hs
@@ -1,183 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}--- |--- Module : Pinch.Internal.TType--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Defines the different types Thrift supports at the protocol level.----module Pinch.Internal.TType- (- -- * TType-- TType(..)- , IsTType(..)- , SomeTType(..)-- , ttypeEquality- , ttypeEqT-- -- * Tags-- , TBool- , TByte- , TDouble- , TInt16- , TInt32- , TEnum- , TInt64- , TBinary- , TText- , TStruct- , TUnion- , TException- , TMap- , TSet- , TList- ) where--import Data.Hashable (Hashable (..))-import Data.Typeable ((:~:) (..), Typeable)---- | > bool-data TBool deriving (Typeable)---- | > byte-data TByte deriving (Typeable)---- | > double-data TDouble deriving (Typeable)---- | > i16-data TInt16 deriving (Typeable)---- | > i32-data TInt32 deriving (Typeable)---- | > enum-type TEnum = TInt32---- | > i64-data TInt64 deriving (Typeable)---- | > binary-data TBinary deriving (Typeable)---- | > string-type TText = TBinary---- | > struct-data TStruct deriving (Typeable)---- | > union-type TUnion = TStruct---- | > exception-type TException = TStruct---- | > map<k, v>-data TMap deriving (Typeable)---- | > set<x>-data TSet deriving (Typeable)---- | > list<x>-data TList deriving (Typeable)----- | Represents the type of a Thrift value.------ Objects of this type are tagged with one of the TType tags, so this type--- also acts as a singleton on the TTypes. It allows writing code that can--- enforce properties about the TType of values at compile time.-data TType a where- TBool :: TType TBool -- 2- TByte :: TType TByte -- 3- TDouble :: TType TDouble -- 4- TInt16 :: TType TInt16 -- 6- TInt32 :: TType TInt32 -- 8- TInt64 :: TType TInt64 -- 10- TBinary :: TType TBinary -- 11- TStruct :: TType TStruct -- 12- TMap :: TType TMap -- 13- TSet :: TType TSet -- 14- TList :: TType TList -- 15- deriving (Typeable)--deriving instance Show (TType a)-deriving instance Eq (TType a)--instance Hashable (TType a) where- hashWithSalt s TBool = s `hashWithSalt` (0 :: Int)- hashWithSalt s TByte = s `hashWithSalt` (1 :: Int)- hashWithSalt s TDouble = s `hashWithSalt` (2 :: Int)- hashWithSalt s TInt16 = s `hashWithSalt` (3 :: Int)- hashWithSalt s TInt32 = s `hashWithSalt` (4 :: Int)- hashWithSalt s TInt64 = s `hashWithSalt` (5 :: Int)- hashWithSalt s TBinary = s `hashWithSalt` (6 :: Int)- hashWithSalt s TStruct = s `hashWithSalt` (7 :: Int)- hashWithSalt s TMap = s `hashWithSalt` (8 :: Int)- hashWithSalt s TSet = s `hashWithSalt` (9 :: Int)- hashWithSalt s TList = s `hashWithSalt` (10 :: Int)----- | Typeclass used to map type-leve TTypes into 'TType' objects. All TType--- tags are instances of this class.-class Typeable a => IsTType a where- -- | Based on the context in which this is used, it will automatically- -- return the corresponding 'TType' object.- ttype :: TType a---instance IsTType TBool where ttype = TBool-instance IsTType TByte where ttype = TByte-instance IsTType TDouble where ttype = TDouble-instance IsTType TInt16 where ttype = TInt16-instance IsTType TInt32 where ttype = TInt32-instance IsTType TInt64 where ttype = TInt64-instance IsTType TBinary where ttype = TBinary-instance IsTType TStruct where ttype = TStruct-instance IsTType TMap where ttype = TMap-instance IsTType TSet where ttype = TSet-instance IsTType TList where ttype = TList----- | Used when the 'TType' for something is not known at compile time.--- Typically, this will be pattern matched inside a case statement and code--- that depends on the TType will be go there.-data SomeTType where- SomeTType :: forall a. IsTType a => TType a -> SomeTType- deriving Typeable--deriving instance Show SomeTType---- | Witness the equality of two ttypes.-ttypeEquality :: TType a -> TType b -> Maybe (a :~: b)-ttypeEquality TBool TBool = Just Refl-ttypeEquality TByte TByte = Just Refl-ttypeEquality TDouble TDouble = Just Refl-ttypeEquality TInt16 TInt16 = Just Refl-ttypeEquality TInt32 TInt32 = Just Refl-ttypeEquality TInt64 TInt64 = Just Refl-ttypeEquality TBinary TBinary = Just Refl-ttypeEquality TStruct TStruct = Just Refl-ttypeEquality TMap TMap = Just Refl-ttypeEquality TSet TSet = Just Refl-ttypeEquality TList TList = Just Refl-ttypeEquality _ _ = Nothing-{-# INLINE ttypeEquality #-}---- | Witness the equality of two TTypes.------ Implicit version of @ttypeEquality@.-ttypeEqT :: forall a b. (IsTType a, IsTType b) => Maybe (a :~: b)-ttypeEqT = ttypeEquality ttype ttype-{-# INLINE ttypeEqT #-}
− Pinch/Internal/Value.hs
@@ -1,203 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}--- |--- Module : Pinch.Internal.Value--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ This module defines an intermediate representation for Thrift values and--- functions to work with the intermediate representation.-module Pinch.Internal.Value- ( Value(..)- , MapItem(..)- , SomeValue(..)- , castValue- , valueTType- ) where--import Control.DeepSeq (NFData (..))-import Data.ByteString (ByteString)-import Data.Hashable (Hashable (..))-import Data.HashMap.Strict (HashMap)-import Data.Int (Int16, Int32, Int64, Int8)-import Data.List (intercalate)-import Data.Typeable ((:~:) (..), Typeable)--import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S--import Pinch.Internal.FoldList (FoldList)-import Pinch.Internal.TType---- | A single item in a map-data MapItem k v = MapItem !(Value k) !(Value v)- deriving (Eq, Typeable)--instance NFData (MapItem k v) where- rnf (MapItem k v) = rnf k `seq` rnf v `seq` ()--instance Hashable (MapItem k v) where- hashWithSalt s (MapItem k v) = s `hashWithSalt` k `hashWithSalt` v--instance Show (MapItem k v) where- show (MapItem k v) = show k ++ ": " ++ show v---- | @Value@ maps directly to serialized representation of Thrift types. It--- contains about as much information as what gets sent over the wire.--- @Value@ objects are tagged with different 'TType' values to indicate the--- type of the value.------ Typical usage will not involve accessing the constructors for this type.--- 'Pinch.Pinchable.Pinchable' must be used to construct 'Value' objects or--- convert them back to original types.-data Value a where- VBool :: !Bool -> Value TBool- VByte :: !Int8 -> Value TByte- VDouble :: !Double -> Value TDouble- VInt16 :: !Int16 -> Value TInt16- VInt32 :: !Int32 -> Value TInt32- VInt64 :: !Int64 -> Value TInt64- VBinary :: !ByteString -> Value TBinary- VStruct :: !(HashMap Int16 SomeValue) -> Value TStruct-- VMap :: forall k v. (IsTType k, IsTType v)- => !(FoldList (MapItem k v)) -> Value TMap- VSet :: forall a. IsTType a => !(FoldList (Value a)) -> Value TSet- VList :: forall a. IsTType a => !(FoldList (Value a)) -> Value TList- deriving Typeable--instance Show (Value a) where- show (VBool x) = show x- show (VByte x) = show x- show (VDouble x) = show x- show (VInt16 x) = "i16(" ++ show x ++ ")"- show (VInt32 x) = "i32(" ++ show x ++ ")"- show (VInt64 x) = "i64(" ++ show x ++ ")"- show (VBinary x) = show x-- show (VStruct x) = "{" ++ s ++ "}"- where- s = intercalate ", " (M.foldlWithKey' go [] x)- go xs i (SomeValue val) = (show i ++ ": " ++ show val):xs-- show (VMap x) = show x- show (VSet x) = show x- show (VList x) = show x--instance Eq (Value a) where- VBool a == VBool b = a == b- VByte a == VByte b = a == b- VDouble a == VDouble b = a == b- VInt16 a == VInt16 b = a == b- VInt32 a == VInt32 b = a == b- VInt64 a == VInt64 b = a == b- VBinary a == VBinary b = a == b- VStruct a == VStruct b = a == b-- VList as == VList bs = areEqual1 as bs- VMap as == VMap bs = areEqual2 (toMap as) (toMap bs)- where- toMap = F.foldl' (\m (MapItem k v) -> M.insert k v m) M.empty- VSet as == VSet bs = areEqual1 (toSet as) (toSet bs)- _ == _ = False--toSet :: forall f x. (F.Foldable f, Hashable x, Eq x) => f x -> S.HashSet x-toSet = F.foldl' (flip S.insert) S.empty--instance NFData (Value a) where- rnf (VBool a) = rnf a- rnf (VByte a) = rnf a- rnf (VDouble a) = rnf a- rnf (VInt16 a) = rnf a- rnf (VInt32 a) = rnf a- rnf (VInt64 a) = rnf a- rnf (VBinary a) = rnf a- rnf (VStruct a) = rnf a- rnf (VMap as) = rnf as- rnf (VSet as) = rnf as- rnf (VList as) = rnf as---- | 'SomeValue' holds any value, regardless of type. This may be used when--- the type of the value is not necessarily known at compile time. Typically,--- this will be pattern matched on and code that depends on the value's--- 'TType' will go inside the scope of the match.-data SomeValue where- SomeValue :: (IsTType a) => !(Value a) -> SomeValue- deriving Typeable--deriving instance Show SomeValue--instance Eq SomeValue where- SomeValue a == SomeValue b = areEqual a b--instance NFData SomeValue where- rnf (SomeValue a) = rnf a---- | Safely attempt to cast a Value into another.-castValue :: forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b)-castValue v = case ttypeEqT of- Just (Refl :: a :~: b) -> Just v- Nothing -> Nothing-{-# INLINE castValue #-}---- | Get the 'TType' of a 'Value'.-valueTType :: IsTType a => Value a -> TType a-valueTType _ = ttype-{-# INLINE valueTType #-}--areEqual- :: forall a b. (IsTType a, IsTType b) => Value a -> Value b -> Bool-areEqual l r = case ttypeEqT of- Just (Refl :: a :~: b) -> l == r- Nothing -> False-{-# INLINE areEqual #-}--areEqual1- :: forall a b f. (IsTType a, IsTType b, Eq (f (Value a)))- => f (Value a) -> f (Value b) -> Bool-areEqual1 l r = case ttypeEqT of- Just (Refl :: a :~: b) -> l == r- Nothing -> False-{-# INLINE areEqual1 #-}--areEqual2- :: forall f k1 v1 k2 v2.- ( IsTType k1, IsTType v1, IsTType k2, IsTType v2- , Eq (f (Value k1) (Value v1))- ) => f (Value k1) (Value v1) -> f (Value k2) (Value v2) -> Bool-areEqual2 l r = case ttypeEqT of- Just (Refl :: k1 :~: k2) -> case ttypeEqT of- Just (Refl :: v1 :~: v2) -> l == r- Nothing -> False- Nothing -> False-{-# INLINE areEqual2 #-}--instance Hashable (Value a) where- hashWithSalt s a = case a of- VBinary x -> s `hashWithSalt` (0 :: Int) `hashWithSalt` x- VBool x -> s `hashWithSalt` (1 :: Int) `hashWithSalt` x- VByte x -> s `hashWithSalt` (2 :: Int) `hashWithSalt` x- VDouble x -> s `hashWithSalt` (3 :: Int) `hashWithSalt` x- VInt16 x -> s `hashWithSalt` (4 :: Int) `hashWithSalt` x- VInt32 x -> s `hashWithSalt` (5 :: Int) `hashWithSalt` x- VInt64 x -> s `hashWithSalt` (6 :: Int) `hashWithSalt` x- VList x -> s `hashWithSalt` (7 :: Int) `hashWithSalt` x- VMap x -> s `hashWithSalt` (8 :: Int) `hashWithSalt` x- VSet x -> s `hashWithSalt` (9 :: Int) `hashWithSalt` x-- VStruct fields ->- M.foldlWithKey' (\s' k v -> s' `hashWithSalt` k `hashWithSalt` v)- (s `hashWithSalt` (10 :: Int))- fields---instance Hashable SomeValue where- hashWithSalt s (SomeValue v) = hashWithSalt s v
− Pinch/Protocol.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- |--- Module : Pinch.Protocol--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Protocols in Pinch only need to know how to serialize and deserialize--- 'Value' objects. Types that want to be serialized into/from Thrift payloads--- define how to convert them to/from 'Value' objects via--- 'Pinch.Pinchable.Pinchable'.-module Pinch.Protocol- ( Protocol(..)- ) where--import Data.ByteString (ByteString)--import Pinch.Internal.Builder (Builder)-import Pinch.Internal.Message (Message)-import Pinch.Internal.TType (IsTType)-import Pinch.Internal.Value (Value)---- | Protocols define a specific way to convert values into binary and back.-data Protocol = Protocol- { serializeValue :: forall a. IsTType a => Value a -> Builder- -- ^ Serializes a 'Value' into a ByteString builder.- --- -- Returns a @Builder@ and the total length of the serialized content.- , serializeMessage :: Message -> Builder- -- ^ Serializes a 'Message' and its payload into a ByteString builder.- --- -- Returns a @Builder@ and the total length of the serialized content.-- , deserializeValue- :: forall a. IsTType a => ByteString -> Either String (Value a)- -- ^ Reads a 'Value' from a ByteString.- , deserializeMessage :: ByteString -> Either String Message- -- ^ Reads a 'Message' and its payload from a ByteString.- }
− Pinch/Protocol/Binary.hs
@@ -1,351 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module : Pinch.Protocol.Binary--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Implements the Thrift Binary Protocol as a 'Protocol'.-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 Pinch.Internal.Builder (Builder)-import Pinch.Internal.Message-import Pinch.Internal.Parser (Parser, 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.-binaryProtocol :: Protocol-binaryProtocol = Protocol- { serializeValue = binarySerialize- , deserializeValue = binaryDeserialize ttype- , serializeMessage = binarySerializeMessage- , deserializeMessage = binaryDeserializeMessage- }----------------------------------------------------------------------------------binarySerializeMessage :: Message -> Builder-binarySerializeMessage msg =- string (TE.encodeUtf8 $ messageName msg) <>- BB.int8 (messageCode (messageType msg)) <> BB.int32BE (messageId msg) <>- binarySerialize (messagePayload msg)--binaryDeserializeMessage :: ByteString -> Either String Message-binaryDeserializeMessage = runParser binaryMessageParser--binaryMessageParser :: Parser Message-binaryMessageParser = do- size <- P.int32- if size < 0- then parseStrict size- else parseNonStrict size- where- -- versionAndType:4 name~4 seqid:4 payload- -- versionAndType = version:2 0x00 type:1- parseStrict versionAndType = do- unless (version == 1) $- fail $ "Unsupported version: " ++ show version- Message- <$> TE.decodeUtf8 <$> (P.int32 >>= P.take . fromIntegral)- <*> typ- <*> P.int32- <*> binaryParser ttype- where- version = (0x7fff0000 .&. versionAndType) `shiftR` 16-- code = fromIntegral $ 0x00ff .&. versionAndType- typ = case fromMessageCode code of- Nothing -> fail $ "Unknown message type: " ++ show code- Just t -> return t-- -- name~4 type:1 seqid:4 payload- parseNonStrict nameLength =- Message- <$> TE.decodeUtf8 <$> P.take (fromIntegral nameLength)- <*> parseMessageType- <*> P.int32- <*> binaryParser ttype---parseMessageType :: Parser MessageType-parseMessageType = P.int8 >>= \code -> case fromMessageCode code of- Nothing -> fail $ "Unknown message type: " ++ show code- Just t -> return t----------------------------------------------------------------------------------binaryDeserialize :: TType a -> ByteString -> Either String (Value a)-binaryDeserialize t = runParser (binaryParser t)--binaryParser :: TType a -> Parser (Value a)-binaryParser typ = case typ of- TBool -> parseBool- TByte -> parseByte- TDouble -> parseDouble- TInt16 -> parseInt16- TInt32 -> parseInt32- TInt64 -> parseInt64- TBinary -> parseBinary- TStruct -> parseStruct- TMap -> parseMap- TSet -> parseSet- TList -> parseList--getTType :: Int8 -> Parser SomeTType-getTType code =- maybe (fail $ "Unknown TType: " ++ show code) return $ fromTypeCode code--parseTType :: Parser SomeTType-parseTType = P.int8 >>= getTType--parseBool :: Parser (Value TBool)-parseBool = VBool . (== 1) <$> P.int8--parseByte :: Parser (Value TByte)-parseByte = VByte <$> P.int8--parseDouble :: Parser (Value TDouble)-parseDouble = VDouble <$> P.double--parseInt16 :: Parser (Value TInt16)-parseInt16 = VInt16 <$> P.int16--parseInt32 :: Parser (Value TInt32)-parseInt32 = VInt32 <$> P.int32--parseInt64 :: Parser (Value TInt64)-parseInt64 = VInt64 <$> P.int64--parseBinary :: Parser (Value TBinary)-parseBinary = VBinary <$> (P.int32 >>= P.take . fromIntegral)---parseMap :: Parser (Value TMap)-parseMap = do- ktype' <- parseTType- vtype' <- parseTType- count <- P.int32-- case (ktype', vtype') of- (SomeTType ktype, SomeTType vtype) -> do- items <- FL.replicateM (fromIntegral count) $- MapItem <$> binaryParser ktype- <*> binaryParser vtype- return $ VMap items---parseSet :: Parser (Value TSet)-parseSet = do- vtype' <- parseTType- count <- P.int32-- case vtype' of- SomeTType vtype ->- VSet <$> FL.replicateM (fromIntegral count) (binaryParser vtype)---parseList :: Parser (Value TList)-parseList = do- vtype' <- parseTType- count <- P.int32-- case vtype' of- SomeTType vtype ->- VList <$> FL.replicateM (fromIntegral count) (binaryParser vtype)---parseStruct :: Parser (Value TStruct)-parseStruct = P.int8 >>= loop M.empty- where- loop :: HashMap Int16 SomeValue -> Int8 -> Parser (Value TStruct)- loop fields 0 = return $ VStruct fields- loop fields code = do- vtype' <- getTType code- fieldId <- P.int16- case vtype' of- SomeTType vtype -> do- value <- SomeValue <$> binaryParser vtype- loop (M.insert fieldId value fields) =<< P.int8-----------------------------------------------------------------------------------binarySerialize :: forall a. IsTType a => Value a -> Builder-binarySerialize = case (ttype :: TType a) of- TBinary -> serializeBinary- TBool -> serializeBool- TByte -> serializeByte- TDouble -> serializeDouble- TInt16 -> serializeInt16- TInt32 -> serializeInt32- TInt64 -> serializeInt64- TStruct -> serializeStruct- TList -> serializeList- TMap -> serializeMap- TSet -> serializeSet-{-# INLINE binarySerialize #-}--serializeBinary :: Value TBinary -> Builder-serializeBinary (VBinary x) = string x-{-# INLINE serializeBinary #-}--serializeBool :: Value TBool -> Builder-serializeBool (VBool x) = BB.int8 $ if x then 1 else 0-{-# INLINE serializeBool #-}--serializeByte :: Value TByte -> Builder-serializeByte (VByte x) = BB.int8 x-{-# INLINE serializeByte #-}--serializeDouble :: Value TDouble -> Builder-serializeDouble (VDouble x) = BB.doubleBE x-{-# INLINE serializeDouble #-}--serializeInt16 :: Value TInt16 -> Builder-serializeInt16 (VInt16 x) = BB.int16BE x-{-# INLINE serializeInt16 #-}--serializeInt32 :: Value TInt32 -> Builder-serializeInt32 (VInt32 x) = BB.int32BE x-{-# INLINE serializeInt32 #-}--serializeInt64 :: Value TInt64 -> Builder-serializeInt64 (VInt64 x) = BB.int64BE x-{-# INLINE serializeInt64 #-}--serializeList :: Value TList -> Builder-serializeList (VList xs) = serializeCollection ttype xs-{-# INLINE serializeList #-}--serializeSet :: Value TSet -> Builder-serializeSet (VSet xs) = serializeCollection ttype xs-{-# INLINE serializeSet #-}--serializeStruct :: Value TStruct -> Builder-serializeStruct (VStruct fields) =- M.foldlWithKey'- (\rest fid (SomeValue val) -> rest <> writeField fid ttype val)- mempty fields- <> BB.int8 0- where- writeField :: IsTType a => Int16 -> TType a -> Value a -> Builder- writeField fieldId fieldType fieldValue =- typeCode fieldType <> BB.int16BE fieldId <> binarySerialize fieldValue- {-# INLINE writeField #-}-{-# INLINE serializeStruct #-}--serializeMap :: Value TMap -> Builder-serializeMap (VMap items) = serialize ttype ttype items- where- serialize- :: (IsTType k, IsTType v)- => TType k -> TType v -> FL.FoldList (MapItem k v) -> Builder- serialize kt vt xs =- typeCode kt <> typeCode vt <> BB.int32BE size <> body- where- (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs- go (prev, !c) (MapItem k v) =- ( prev <> binarySerialize k <> binarySerialize v- , c + 1- )-{-# INLINE serializeMap #-}--serializeCollection- :: IsTType a- => TType a -> FL.FoldList (Value a) -> Builder-serializeCollection vtype xs =- let go (prev, !c) item = (prev <> binarySerialize item, c + 1)- (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs- in typeCode vtype <> BB.int32BE size <> body-{-# INLINE serializeCollection #-}-----------------------------------------------------------------------------------messageCode :: MessageType -> Int8-messageCode Call = 1-messageCode Reply = 2-messageCode Exception = 3-messageCode Oneway = 4-{-# INLINE messageCode #-}---fromMessageCode :: Int8 -> Maybe MessageType-fromMessageCode 1 = Just Call-fromMessageCode 2 = Just Reply-fromMessageCode 3 = Just Exception-fromMessageCode 4 = Just Oneway-fromMessageCode _ = Nothing-{-# INLINE fromMessageCode #-}----- | Map a TType to its type code.-toTypeCode :: TType a -> Int8-toTypeCode TBool = 2-toTypeCode TByte = 3-toTypeCode TDouble = 4-toTypeCode TInt16 = 6-toTypeCode TInt32 = 8-toTypeCode TInt64 = 10-toTypeCode TBinary = 11-toTypeCode TStruct = 12-toTypeCode TMap = 13-toTypeCode TSet = 14-toTypeCode TList = 15-{-# INLINE toTypeCode #-}----- | Map a type code to the corresponding TType.-fromTypeCode :: Int8 -> Maybe SomeTType-fromTypeCode 2 = Just $ SomeTType TBool-fromTypeCode 3 = Just $ SomeTType TByte-fromTypeCode 4 = Just $ SomeTType TDouble-fromTypeCode 6 = Just $ SomeTType TInt16-fromTypeCode 8 = Just $ SomeTType TInt32-fromTypeCode 10 = Just $ SomeTType TInt64-fromTypeCode 11 = Just $ SomeTType TBinary-fromTypeCode 12 = Just $ SomeTType TStruct-fromTypeCode 13 = Just $ SomeTType TMap-fromTypeCode 14 = Just $ SomeTType TSet-fromTypeCode 15 = Just $ SomeTType TList-fromTypeCode _ = Nothing-{-# INLINE fromTypeCode #-}-----------------------------------------------------------------------------------string :: ByteString -> Builder-string b = BB.int32BE (fromIntegral $ B.length b) <> BB.byteString b-{-# INLINE string #-}--typeCode :: TType a -> Builder-typeCode = BB.int8 . toTypeCode-{-# INLINE typeCode #-}
− bench/Bench.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-module Main (main) where--import Control.DeepSeq (NFData)-import Criterion-import Criterion.Main (defaultMain)-import Data.ByteString (ByteString)-import Data.Int-import Data.Text (Text)-import GHC.Generics (Generic)-import Pinch ((.:), (.=))--import qualified Data.Text as T-import qualified Pinch as P-import qualified Test.QuickCheck as QC--data A = A- { aName :: Text- , aBirthDay :: Int64- , aPhone :: Text- , aSiblings :: Int32- , aSpouse :: Bool- , aMoney :: Double- } deriving (Show, Ord, Eq, Generic)--instance NFData A--instance QC.Arbitrary A where- arbitrary = A- <$> (T.pack <$> QC.arbitrary)- <*> QC.arbitrary- <*> (T.pack <$> QC.arbitrary)- <*> QC.arbitrary- <*> QC.arbitrary- <*> QC.arbitrary---instance P.Pinchable A where- type Tag A = P.TStruct-- pinch A{..} = P.struct- [ 1 .= aName- , 2 .= aBirthDay- , 3 .= aPhone- , 4 .= aSiblings- , 5 .= aSpouse- , 6 .= aMoney- ]-- unpinch m = A- <$> m .: 1- <*> m .: 2- <*> m .: 3- <*> m .: 4- <*> m .: 5- <*> m .: 6---data A2 = A2- { a2Name :: P.Field 1 Text- , a2BirthDay :: P.Field 2 Int64- , a2Phone :: P.Field 3 Text- , a2Siblings :: P.Field 4 Int32- , a2Spouse :: P.Field 5 Bool- , a2Money :: P.Field 6 Double- } deriving (Show, Ord, Eq, Generic)--instance P.Pinchable A2-instance NFData A2--instance QC.Arbitrary A2 where- arbitrary = A2- <$> (P.putField . T.pack <$> QC.arbitrary)- <*> (P.putField <$> QC.arbitrary)- <*> (P.putField . T.pack <$> QC.arbitrary)- <*> (P.putField <$> QC.arbitrary)- <*> (P.putField <$> QC.arbitrary)- <*> (P.putField <$> QC.arbitrary)---main :: IO ()-main = defaultMain- [ bgroup "Pinch"- [ env (generate :: IO A) $ \a ->- bench "encode" $ whnf (P.encode P.binaryProtocol) a- , env (P.encode P.binaryProtocol <$> (generate :: IO A)) $ \bs ->- bench "decode" $- whnf (P.decode P.binaryProtocol :: ByteString -> Either String A) bs- ]- , bgroup "Pinch Generic"- [ env (generate :: IO A2) $ \a ->- bench "encode" $ whnf (P.encode P.binaryProtocol) a- , env (P.encode P.binaryProtocol <$> (generate :: IO A2)) $ \bs ->- bench "decode" $- whnf (P.decode P.binaryProtocol :: ByteString -> Either String A2) bs- ]- ]- where- generate :: QC.Arbitrary a => IO a- generate = QC.generate QC.arbitrary
+ bench/pinch-bench/Bench.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Control.DeepSeq (NFData)+import Control.Exception (bracket_)+import Control.Monad+import Criterion+import Criterion.Main (defaultMain)+import Data.ByteString (ByteString)+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Int+import Data.Text (Text)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import GHC.Profiling+import Pinch ((.:), (.=))++import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Pinch as P+import qualified Test.QuickCheck as QC++------------------------------------------------------------------------------++data A = A+ { aName :: Text+ , aBirthDay :: Int64+ , aPhone :: Text+ , aSiblings :: Int32+ , aSpouse :: Bool+ , aMoney :: Double+ } deriving (Show, Ord, Eq, Generic)++instance NFData A++instance QC.Arbitrary A where+ arbitrary = A+ <$> (T.pack <$> replicateM 30 QC.arbitrary)+ <*> QC.arbitrary+ <*> (T.pack <$> replicateM 10 QC.arbitrary)+ <*> QC.arbitrary+ <*> QC.arbitrary+ <*> QC.arbitrary++instance P.Pinchable A where+ type Tag A = P.TStruct++ pinch A{..} = P.struct+ [ 1 .= aName+ , 2 .= aBirthDay+ , 3 .= aPhone+ , 4 .= aSiblings+ , 5 .= aSpouse+ , 6 .= aMoney+ ]++ unpinch m = A+ <$> m .: 1+ <*> m .: 2+ <*> m .: 3+ <*> m .: 4+ <*> m .: 5+ <*> m .: 6++------------------------------------------------------------------------------++data NestedMixed = NestedMixed+ { nestedMixedIntSetList :: Vector (HashSet Int32)+ , nestedMixedMapIntStrset :: HashMap Int32 (HashSet ByteString)+ , nestedMixedMapIntStrsetList :: Vector (HashMap Int32 (HashSet ByteString))+ } deriving (Show, Eq, Generic)++instance NFData NestedMixed++generateNestedMixedFields+ :: IO ( Vector (HashSet Int32)+ , HashMap Int32 (HashSet ByteString)+ , Vector (HashMap Int32 (HashSet ByteString))+ )+generateNestedMixedFields = bracket_ stopProfTimer startProfTimer $+ QC.generate $+ (,,) <$> V.replicateM 100 (HS.fromList <$> replicateM 100 QC.arbitrary)+ <*> genHM+ <*> V.replicateM 100 genHM+ where+ genHM = HM.fromList <$> replicateM 100 ((,) <$> QC.arbitrary <*> stringSet)+ stringSet = HS.fromList <$> replicateM 100 genBS+ genBS = B.pack <$> replicateM 16 QC.arbitrary++instance P.Pinchable NestedMixed where+ type Tag NestedMixed = P.TStruct++ pinch NestedMixed{..} = P.struct+ [ 1 .= nestedMixedIntSetList+ , 2 .= nestedMixedMapIntStrset+ , 3 .= nestedMixedMapIntStrsetList+ ]++ unpinch m = NestedMixed+ <$> m .: 1+ <*> m .: 2+ <*> m .: 3++------------------------------------------------------------------------------++data Struct = Struct+ { structStrings :: Vector ByteString+ , structInts :: HashSet Int32+ , structMapped :: HashMap Int32 ByteString+ } deriving (Show, Eq, Generic)++structFields+ :: IO+ ( Vector ByteString+ , HashSet Int32+ , HashMap Int32 ByteString+ )+structFields = bracket_ stopProfTimer startProfTimer $ return+ ( V.replicate 100000 "foo"+ , HS.fromList [1..100000]+ , HM.fromList [(n, "bar") | n <- [1..100000]]+ )++instance NFData Struct++instance P.Pinchable Struct where+ type Tag Struct = P.TStruct++ pinch Struct{..} = P.struct+ [ 1 .= structStrings+ , 2 .= structInts+ , 3 .= structMapped+ ]++ unpinch m = Struct+ <$> m .: 1+ <*> m .: 2+ <*> m .: 3++------------------------------------------------------------------------------++main :: IO ()+main = defaultMain+ [ bgroup "A"+ [ env (generate :: IO A) $ \a -> bench "encode" $ whnf encode a+ , env generateEncodedA $ \bs -> bench "decode" $+ nf (P.decode P.binaryProtocol :: ByteString -> Either String A) bs+ ]+ , bgroup "NestedMixed"+ [ env generateNestedMixedFields $ \ ~(f1, f2, f3) -> bench "encode" $+ whnf encode (NestedMixed f1 f2 f3)+ , env generateEncodedNestedMixed $ \bs -> bench "decode" $+ nf (P.decode P.binaryProtocol :: ByteString -> Either String NestedMixed) bs+ ]+ , bgroup "Struct"+ [ env structFields $ \ ~(f1, f2, f3) -> bench "encode" $+ whnf encode (Struct f1 f2 f3)+ , env generateEncodedStruct $ \bs -> bench "deode" $+ nf (P.decode P.binaryProtocol :: ByteString -> Either String Struct) bs+ ]+ ]+ where+ generateEncodedNestedMixed = bracket_ stopProfTimer startProfTimer $ do+ (f1, f2, f3) <- generateNestedMixedFields+ return $ P.encode P.binaryProtocol (NestedMixed f1 f2 f3)++ generateEncodedA = bracket_ stopProfTimer startProfTimer $ do+ a <- generate :: IO A+ return $ P.encode P.binaryProtocol a++ generateEncodedStruct = bracket_ stopProfTimer startProfTimer $ do+ (f1, f2, f3) <- structFields+ return $ P.encode P.binaryProtocol (Struct f1 f2 f3)++ generate :: QC.Arbitrary a => IO a+ generate = QC.generate QC.arbitrary++ encode :: P.Pinchable a => a -> ByteString+ encode = P.encode P.binaryProtocol
+ bench/pinch-bench/pinch-bench.cabal view
@@ -0,0 +1,22 @@+name : pinch-bench+version : 0.1.0.0+author : Abhinav Gupta+maintainer : mail@abhinavg.net+build-type : Simple+cabal-version : >=1.10++executable pinch-bench+ main-is : Bench.hs+ ghc-options : -Wall+ build-depends : base+ , bytestring+ , criterion >= 1.0+ , deepseq+ , hashable+ , QuickCheck >= 2.8+ , text+ , unordered-containers+ , vector++ , pinch+ default-language : Haskell2010
examples/keyvalue/keyvalue.cabal view
@@ -12,7 +12,7 @@ build-depends : base , bytestring , containers- , http-types >= 0.8 && < 0.9+ , http-types , text , wai >= 3.0 && < 4.0 , warp >= 3.0 && < 4.0@@ -28,8 +28,8 @@ , bytestring , containers , exceptions- , http-client >= 0.4 && < 0.5- , http-types >= 0.8 && < 0.9+ , http-client >= 0.4+ , http-types >= 0.8 , text , pinch
pinch.cabal view
@@ -1,113 +1,109 @@-name: pinch-version: 0.2.0.0-synopsis: An alternative implementation of Thrift for Haskell.-homepage: https://github.com/abhinav/pinch-license: BSD3-license-file: LICENSE-author: Abhinav Gupta-maintainer: mail@abhinavg.net-category: Development-build-type: Simple-cabal-version: >=1.10-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.- .- /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.+-- This file has been generated from package.yaml by hpack version 0.13.0.+--+-- see: https://github.com/sol/hpack++name: pinch+version: 0.2.0.1+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+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.+ .+ /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+author: Abhinav Gupta+ extra-source-files:- README.md+ bench/pinch-bench/Bench.hs+ bench/pinch-bench/pinch-bench.cabal CHANGES.md- examples/keyvalue/*.hs- examples/keyvalue/*.cabal- examples/keyvalue/*.thrift+ 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 +source-repository head+ type: git+ location: https://github.com/abhinav/pinch library- exposed-modules : 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- other-modules : Pinch.Internal.Bits- , Pinch.Internal.Pinchable.Parser- ghc-options : -Wall- build-depends : base >= 4.7 && < 4.9-- , array >= 0.5- , bytestring >= 0.10 && < 0.11- , containers >= 0.5 && < 0.6- , deepseq >= 1.3 && < 1.5- , ghc-prim- , hashable >= 1.2 && < 1.3- , text >= 1.2 && < 1.3- , unordered-containers >= 0.2 && < 0.3- , vector >= 0.10 && < 0.12- default-language : Haskell2010-+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >= 4.7 && < 5,+ bytestring >= 0.10 && < 0.11,+ containers >= 0.5 && < 0.6,+ text >= 1.2 && < 1.3,+ unordered-containers >= 0.2 && < 0.3,+ vector >= 0.10 && < 0.12,+ array >= 0.5,+ deepseq >= 1.3 && < 1.5,+ ghc-prim,+ hashable >= 1.2 && < 1.3+ 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+ other-modules:+ Pinch.Internal.Bits+ Pinch.Internal.Pinchable.Parser+ Paths_pinch+ default-language: Haskell2010 test-suite pinch-spec- type : exitcode-stdio-1.0- hs-source-dirs : tests- ghc-options : -Wall- main-is : Spec.hs- other-modules : Pinch.Arbitrary- , Pinch.Expectations- , Pinch.Protocol.BinarySpec- , Pinch.Internal.BuilderSpec- , Pinch.Internal.BuilderParserSpec- , Pinch.Internal.FoldListSpec- , Pinch.Internal.GenericSpec- , Pinch.Internal.ParserSpec- , Pinch.Internal.PinchableSpec- , Pinch.Internal.TTypeSpec- , Pinch.Internal.Util- , Pinch.Internal.ValueSpec- build-depends : base-- , bytestring- , containers- , hspec >= 2.0- , hspec-discover >= 2.1- , QuickCheck >= 2.5- , text- , unordered-containers- , vector-- , pinch- default-language : Haskell2010---benchmark pinch-bench- type : exitcode-stdio-1.0- main-is : Bench.hs- hs-source-dirs : bench- ghc-options : -O2 -Wall- build-depends : base- , bytestring- , criterion >= 1.0- , deepseq- , QuickCheck >= 2.8- , text-- , pinch- default-language : Haskell2010---source-repository head- type : git- location : git://github.com/abhinav/pinch.git+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ tests+ ghc-options: -Wall+ build-depends:+ base >= 4.7 && < 5,+ bytestring >= 0.10 && < 0.11,+ containers >= 0.5 && < 0.6,+ text >= 1.2 && < 1.3,+ unordered-containers >= 0.2 && < 0.3,+ vector >= 0.10 && < 0.12,+ hspec >= 2.0,+ hspec-discover >= 2.1,+ pinch,+ QuickCheck >= 2.5+ 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+ default-language: Haskell2010
+ src/Pinch.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Pinch+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Pinch defines machinery to specify how types can be encoded into or decoded+-- from Thrift payloads.+--+module Pinch+ (++ -- * Serializing and deserializing++ -- $encodeDecodeValues++ encode+ , decode++ -- * RPC++ -- $rpc++ , encodeMessage+ , decodeMessage++ -- * Pinchable++ , Pinchable(..)+ , Parser+ , runParser++ -- ** Automatically deriving instances++ -- | Pinch supports deriving instances of 'Pinchable' automatically for+ -- types that implement the @Generic@ typeclass provided that they follow+ -- the outlined patterns in their constructors.++ -- *** Structs and exceptions+ -- $genericStruct++ -- *** Unions+ -- $genericUnion++ , Field(..)+ , getField+ , putField+ , field++ , Void(..)++ -- *** Enums+ -- $genericEnum++ , Enumeration(..)+ , enum++ -- ** Manually writing instances++ -- | Instances of 'Pinchable' can be constructed by composing together+ -- existing instances and using the '.=', '.:', etc. helpers.++ -- *** Structs and exceptions+ -- $struct++ -- *** Unions+ -- $union++ -- *** Enums+ -- $enum++ -- ** Helpers++ -- *** @pinch@++ , (.=)+ , (?=)+ , struct+ , union+ , FieldPair++ -- *** @unpinch@++ , (.:)+ , (.:?)++ -- * Value++ -- | 'Value' is an intermediate representation of Thrift payloads tagged+ -- with TType tags. Types that want to be serialized into\/deserialized+ -- from Thrift payloads need only define a way to convert themselves to+ -- and from 'Value' objects via 'Pinchable'.++ , Value+ , SomeValue(..)++ -- * Messages++ , Message+ , mkMessage+ , messageName+ , messageType+ , messageId+ , getMessageBody++ , MessageType(..)++ -- * Protocols++ , Protocol+ , binaryProtocol++ -- * TType++ -- | TType is used to refer to the Thrift protocol-level type of a value.++ , TType+ , IsTType(..)++ -- ** Tags++ -- | TType tags allow writing code that depends on knowing the @TType@ of+ -- values, or asserting conditions on it, at compile time.+ --+ -- For example, values in a map, list, or set must all have the same TType.+ -- This is enforced at the type level by parameterizing 'Value' over these+ -- tags.++ , TBool+ , TByte+ , TDouble+ , TEnum+ , TInt16+ , TInt32+ , TInt64+ , TBinary+ , TStruct+ , TUnion+ , TException+ , TMap+ , TSet+ , TList+ ) where++import Control.Monad+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text (Text)++import Pinch.Internal.Builder (runBuilder)+import Pinch.Internal.Generic+import Pinch.Internal.Message+import Pinch.Internal.Pinchable+import Pinch.Internal.TType+import Pinch.Internal.Value+import Pinch.Protocol+import Pinch.Protocol.Binary++------------------------------------------------------------------------------++-- $encodeDecodeValues+--+-- Types that can be serialized and deserialized into\/from Thrift values+-- implement the 'Pinchable' typeclass. Instances may be derived automatically+-- using generics, or written out by hand.+--+-- The 'Pinchable' typeclass converts objects into and from 'Value' objects,+-- which act as a direct mapping to the Thrift wire representation. A+-- 'Protocol' is responsible for converting 'Value' objects to and from+-- bytestrings.+--+-- The 'encode' and 'decode' methods may be used on objects that implement the+-- 'Pinchable' typeclass to get the wire representation directly.+--+-- > +------------+ Pinchable Protocol +------------++-- > | | +------------+ | |+-- > | +----pinch------> +---serialize---> |+-- > | Your Type | | Value a | | ByteString |+-- > | <---unpinch-----+ <--deserialize--+ |+-- > | | +------------+ | |+-- > | | | |+-- > | +-------------------encode-------------------> |+-- > | | | |+-- > | <-------------------decode-------------------+ |+-- > +------------+ +------------+++-- | Encode the given 'Pinchable' value using the given 'Protocol'.+--+-- >>> unpack $ encode binaryProtocol ["a" :: ByteString, "b"]+-- [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]+--+encode :: Pinchable a => Protocol -> a -> ByteString+encode p = runBuilder . serializeValue p . pinch+{-# INLINE encode #-}++-- | Decode a 'Pinchable' value from the using the given 'Protocol'.+--+-- >>> let s = pack [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]+-- >>> decode binaryProtocol s :: Either String [ByteString]+-- Right ["a","b"]+--+decode :: Pinchable a => Protocol -> ByteString -> Either String a+decode p = deserializeValue p >=> runParser . unpinch+{-# INLINE decode #-}++------------------------------------------------------------------------------++-- $rpc+--+-- Thrift requests implicitly form a struct and responses implicitly form a+-- union. To send\/receive the request\/response, it must be wrapped inside a+-- 'Message'. The 'Message' contains information like the method name, the+-- message ID (to match out of order responses with requests), and whether+-- it contains a request or a response.+--+-- Requests and responses may be wrapped into @Message@ objects using the+-- 'mkMessage' function. The message body can be retrieved back using the+-- 'getMessageBody' function. The 'encodeMessage' and 'decodeMessage'+-- functions may be used to encode and decode messages into\/from bytestrings.+--+-- Consider the service method,+--+-- > User getUser(1: string userName, 2: list<Attribute> attributes)+-- > throws (1: UserDoesNotExist doesNotExist,+-- > 2: InternalError internalError)+--+-- The request and response for this method implictly take the form:+--+-- > struct getUserRequest {+-- > 1: string userName+-- > 2: list<Attribute> attributes+-- > }+--+-- > union getUserResponse {+-- > 0: User success+-- > 1: UserDoesNotExist doesNotExist+-- > 2: InternalError InternalError+-- > }+--+-- (Note that the field ID 0 is reserved for the return value of the method.)+--+-- Given corresponding data types @GetUserRequest@ and @GetUserResponse@, the+-- client can do something similar to,+--+-- @+-- let req = GetUserRequest "jsmith" []+-- msg = 'mkMessage' "getUser" 'Call' 0 req+-- response <- sendToServer ('encodeMessage' msg)+-- case 'decodeMessage' response of+-- Left err -> handleError err+-- Right msg -> case 'getMessageBody' msg of+-- Left err -> handleError err+-- Right (res :: GetUserResponse) -> handleResponse res+-- @+--+-- Similarly, on the server side,+--+-- @+-- case decodeMessage request of+-- Left err -> handleError err+-- Right msg -> case 'messageName' msg of+-- "getUser" -> case getMessageBody msg of+-- Left err -> handleError err+-- Right (req :: GetUserRequest) -> do+-- let mid = 'messageId' msg+-- res <- handleGetUser req+-- return (mkMessage "getUser" 'Reply' mid res)+-- -- Note that the response MUST contain the same+-- -- message ID as its request.+-- _ -> handleUnknownMethod+-- @++-- | Encode the 'Message' using the given 'Protocol'.+--+-- @+-- let request = GetUserRequest (putField "jsmith") (putField [])+-- message = 'mkMessage' "getUser" Call 42 request+-- in encodeMessage binaryProtocol message+-- @+--+encodeMessage :: Protocol -> Message -> ByteString+encodeMessage p = runBuilder . serializeMessage p+{-# INLINE encodeMessage #-}++-- | Decode a 'Message' using the given 'Protocol'.+--+-- >>> decodeMessage binaryProtocol bs >>= getMessageBody :: Either String GetUserRequest+-- Right (GetUserRequest {userName = Field "jsmith", userAttributes = Field []})+--+decodeMessage :: Protocol -> ByteString -> Either String Message+decodeMessage = deserializeMessage+{-# INLINE decodeMessage #-}++-- | Build a @Message@.+mkMessage+ :: (Pinchable a, Tag a ~ TStruct)+ => Text+ -- ^ Name of the target method.+ -> MessageType+ -- ^ Type of the message.+ -> Int32+ -- ^ Message ID.+ -> a+ -- ^ Message payload. This must be an object which serializes into a+ -- struct.+ -> Message+mkMessage name typ mid body = Message name typ mid (pinch body)+{-# INLINE mkMessage #-}++-- | Read the message contents.+--+-- This returns a @Left@ result if the message contents do not match the+-- requested type.+getMessageBody+ :: (Pinchable a, Tag a ~ TStruct) => Message -> Either String a+getMessageBody = runParser . unpinch . messagePayload+{-# INLINE getMessageBody #-}++------------------------------------------------------------------------------++-- $genericStruct+--+-- Given the struct,+--+-- > struct User {+-- > 1: required string name+-- > 2: optional string emailAddress+-- > }+--+-- A @Pinchable@ instance for it can be automatically derived by wrapping+-- fields of the data type with the 'Field' type and specifying the field+-- identifier as a type-level numeral. Fields which hold a @Maybe@ value are+-- considered optional.+--+-- @+-- data User = User+-- { userName :: 'Field' 1 Text+-- , userEmailAddress :: Field 2 (Maybe Text)+-- }+-- deriving (Generic)+--+-- instance Pinchable User+-- @+--+-- The @DeriveGeneric@ extension is required to automatically derive instances+-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use+-- type-level numerals.++------------------------------------------------------------------------------++-- $genericUnion+--+-- As with structs and exceptions, fields of the data type representing a+-- union must be tagged with 'Field', but to satisfy the property of a union+-- that only one value is set at a time, they must be on separate+-- constructors.+--+-- For example, given the union,+--+-- > union Item {+-- > 1: binary bin+-- > 2: string str+-- > 3: i32 int+-- > }+--+-- A @Pinchable@ instance can be derived like so,+--+-- > data Item+-- > = ItemBin (Field 1 ByteString)+-- > | ItemStr (Field 2 Text)+-- > | ItemInt (Field 3 Int32)+-- > deriving (Generic)+-- >+-- > instance Pinchable Item+--+-- The @DeriveGeneric@ extension is required to automatically derive instances+-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use+-- type-level numerals.+--+-- If the union represents the response of a service method which returns a+-- @void@ result, the type 'Void' may be used.+--+-- @+-- data GetFooResponse+-- = GetFooDoesNotExist (Field 1 FooDoesNotExist)+-- | GetFooInternalError (Field 2 InternalError)+-- | GetFooSuccess 'Void'+-- @++------------------------------------------------------------------------------++-- $genericEnum+--+-- Given the enum,+--+-- > enum Op {+-- > Add, Sub, Mul, Div+-- > }+--+-- A @Pinchable@ instance can be derived for it by creating one constructor+-- for each of the enum values and providing it a single 'Enumeration'+-- argument tagged with the enum value.+--+-- @+-- data Op+-- = OpAdd ('Enumeration' 0)+-- | OpSub (Enumeration 1)+-- | OpMul (Enumeration 2)+-- | OpDiv (Enumeration 3)+-- deriving (Generic)+--+-- instance Pinchable Op+-- @+--+-- Note that you need to know the values assigned to the enums. If not+-- specified, Thrift automatically assigns incrementing values to the items in+-- the order they appear starting at 0.+--+-- The @DeriveGeneric@ extension is required to automatically derive instances+-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use+-- type-level numerals.++------------------------------------------------------------------------------++-- $struct+--+-- Given a Thrift struct,+--+-- > struct Post {+-- > 1: optional string subject+-- > 2: required string body+-- > }+--+-- The 'Pinchable' instance for it will be,+--+-- @+-- data Post = Post+-- { postSubject :: Maybe Text+-- , postBody :: Text+-- }+--+-- instance 'Pinchable' Post where+-- type 'Tag' Post = 'TStruct'+--+-- pinch (Post subject body) =+-- 'struct' [ 1 '?=' subject+-- , 2 '.=' body+-- ]+--+-- unpinch value =+-- Post \<$\> value '.:?' 1+-- \<*\> value '.:' 2+-- @+--++------------------------------------------------------------------------------++-- $union+--+-- Given a Thrift union,+--+-- > union PostBody {+-- > 1: string markdown+-- > 2: binary rtf+-- > }+--+-- The 'Pinchable' instance for it will be,+--+-- @+-- data PostBody+-- = PostBodyMarkdown Text+-- | PostBodyRtf ByteString+--+-- instance Pinchable PostBody where+-- type Tag PostBody = 'TUnion'+--+-- pinch (PostBodyMarkdown markdownBody) =+-- 'union' 1 markdownBody+-- pinch (PostBodyRtf rtfBody) =+-- union 2 rtfBody+--+-- unpinch v = PostBodyMarkdown \<$\> v .: 1+-- \<|\> PostBodyRtf \<$\> v .: 2+-- @++------------------------------------------------------------------------------++-- $enum+--+-- Given an enum,+--+-- > enum Role {+-- > DISABLED = 0,+-- > USER,+-- > ADMIN,+-- > }+--+-- The 'Pinchable' instance for it will be,+--+-- > data Role = RoleDisabled | RoleUser | RoleAdmin+-- >+-- > instance Pinchable Role where+-- > type Tag Role = TEnum+-- >+-- > pinch RoleDisabled = pinch (0 :: Int32)+-- > pinch RoleUser = pinch (1 :: Int32)+-- > pinch RoleAdmin = pinch (2 :: Int32)+-- >+-- > unpinch v = do+-- > value <- unpinch v+-- > case (value :: Int32) of+-- > 0 -> Right RoleDisabled+-- > 1 -> Right RoleUser+-- > 2 -> Right RoleAdmin+-- > _ -> Left $ "Unknown role: " ++ show value
+ src/Pinch/Internal/Bits.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+-- |+-- Module : Pinch.Internal.Bits+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Provides unchecked bitwise shift operations. Similar versions of @shiftR@+-- are used by @ByteString.Builder.Prim@.+module Pinch.Internal.Bits+ ( w16ShiftL+ , w32ShiftL+ , w64ShiftL+ ) where++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base (Int (..), uncheckedShiftL#)+import GHC.Word (Word16 (..), Word32 (..), Word64 (..))+#else+import Data.Bits (shiftL)+import Data.Word (Word16, Word32, Word64)+#endif++{-# INLINE w16ShiftL #-}+w16ShiftL :: Word16 -> Int -> Word16++{-# INLINE w32ShiftL #-}+w32ShiftL :: Word32 -> Int -> Word32++{-# INLINE w64ShiftL #-}+w64ShiftL :: Word64 -> Int -> Word64++-- If we're not on GHC, the regular shiftL will be returned.++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+w16ShiftL (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)+w32ShiftL (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)+w64ShiftL (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#else+w16ShiftL = shiftL+w32ShiftL = shiftL+w64ShiftL = shiftL+#endif
+ src/Pinch/Internal/Builder.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Pinch.Internal.Builder+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- This module implements a ByteString builder very similar to+-- 'Data.ByteString.Builder' except that it keeps track of its final serialized+-- length. This allows it to allocate the target ByteString in one @malloc@ and+-- simply write the bytes to it.+module Pinch.Internal.Builder+ ( Builder+ , runBuilder++ , append+ , int8+ , int16BE+ , int32BE+ , int64BE+ , doubleBE+ , byteString+ ) where++#if __GLASGOW_HASKELL__ < 709+import Data.Monoid+#endif++import Data.ByteString (ByteString)+import Data.ByteString.Builder.Prim ((>*<))+import Data.Int+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)++import qualified Data.ByteString.Builder.Prim as BP+import qualified Data.ByteString.Builder.Prim.Internal as BPI+import qualified Data.ByteString.Internal as BI++-- | A ByteString Builder that knows its final size.+data Builder = B {-# UNPACK #-} !Int (Ptr Word8 -> IO ())++-- | Build a ByteString from the given ByteString builder.+runBuilder :: Builder -> ByteString+runBuilder (B size fill) = BI.unsafeCreate size fill+{-# INLINE runBuilder #-}++-- | Append two Builders into one.+append :: Builder -> Builder -> Builder+append (B ll lf) (B rl rf) = B (ll + rl) (\p -> lf p >> rf (p `plusPtr` ll))+{-# INLINE [1] append #-}+ -- Don't inline append until phase 1. This ensures that the+ -- append/primFixed* rules have a chance to fire.++instance Monoid Builder where+ {-# INLINE mempty #-}+ mempty = B 0 (\_ -> return ())++ {-# INLINE mappend #-}+ mappend = append++ {-# INLINE mconcat #-}+ mconcat = foldr mappend mempty++primFixed :: BP.FixedPrim a -> a -> Builder+primFixed prim a = B (BPI.size prim) (BPI.runF prim a)+{-# INLINE [1] primFixed #-}+ -- Don't inline append until phase 1. This ensures that the+ -- append/primFixed* rules have a chance to fire.++-- The following rules try to join together instances of primFixed that are+-- being appended together. These were adapted almost as-is from+-- ByteString.Builder.Prim's rules around this.++{-# RULES++"append/primFixed" forall p1 p2 v1 v2.+ append (primFixed p1 v1) (primFixed p2 v2) =+ primFixed (p1 >*< p2) (v1, v2)++"append/primFixed/rightAssociative" forall p1 p2 v1 v2 b.+ append (primFixed p1 v1) (append (primFixed p2 v2) b) =+ append (primFixed (p1 >*< p2) (v1, v2)) b++"append/primFixed/leftAssociative" forall p1 p2 v1 v2 b.+ append (append b (primFixed p1 v1)) (primFixed p2 v2) =+ append b (primFixed (p1 >*< p2) (v1, v2))++ #-}++-- | Serialize a single signed byte.+int8 :: Int8 -> Builder+int8 = primFixed BP.int8+{-# INLINE int8 #-}++-- | Serialize a signed 16-bit integer in big endian format.+int16BE :: Int16 -> Builder+int16BE = primFixed BP.int16BE+{-# INLINE int16BE #-}++-- | Serialize a signed 32-bit integer in big endian format.+int32BE :: Int32 -> Builder+int32BE = primFixed BP.int32BE+{-# INLINE int32BE #-}++-- | Serialize a signed 64-bit integer in big endian format.+int64BE :: Int64 -> Builder+int64BE = primFixed BP.int64BE+{-# INLINE int64BE #-}++-- | Serialize a signed 64-bit floating point number in big endian format.+doubleBE :: Double -> Builder+doubleBE = primFixed BP.doubleBE+{-# INLINE doubleBE #-}++-- | Inlcude the given ByteString as-is in the builder.+--+-- Note that because this operation is applied lazily, we will maintain a+-- reference to the ByteString until the builder is executed.+byteString :: ByteString -> Builder+byteString (BI.PS fp off len) =+ B len $ \dst ->+ withForeignPtr fp $ \src ->+ BI.memcpy dst (src `plusPtr` off) len+{-# INLINE byteString #-}
+ src/Pinch/Internal/FoldList.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Pinch.Internal.FoldList+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Implements a representation of a list as a fold over it.+module Pinch.Internal.FoldList+ ( FoldList+ , map+ , replicate+ , replicateM+ , F.foldl'+ , F.foldr+ , F.toList+ , fromFoldable+ , fromMap+ , T.mapM+ , T.sequence+ ) where++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.Monoid+import Data.Typeable (Typeable)++import qualified Control.Monad as M+import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Traversable as T++-- | FoldList represents a list as a @foldl'@ traversal over it.+--+-- This allows us to avoid allocating new collections for an intermediate+-- representation of various data types that users provide.+newtype FoldList a = FoldList (forall r. (r -> a -> r) -> r -> r)+ deriving Typeable++-- | Builds a FoldList over pairs of items of a map.+fromMap+ :: (forall r. (r -> k -> v -> r) -> r -> m k v -> r)+ -- ^ @foldlWithKey@ provided by the map implementation.+ -> m k v+ -> FoldList (k, v)+fromMap foldlWithKey m = FoldList (\k r -> foldlWithKey (go k) r m)+ where+ go k r a b = k r (a, b)+ {-# INLINE go #-}+{-# INLINE fromMap #-}++-- | Builds a FoldList from a Foldable.+fromFoldable :: F.Foldable f => f a -> FoldList a+fromFoldable l = FoldList (\k r -> F.foldl' k r l)+{-# INLINE fromFoldable #-}++-- | Applies the given function to all elements in the FoldList.+--+-- Note that the function is applied lazily when the results are requested. If+-- the results of the same FoldList are requested multiple times, the function+-- will be called multiple times on the same elements.+map :: (a -> b) -> FoldList a -> FoldList b+map f (FoldList l) = FoldList $ \k r0 -> l (\r1 a -> k r1 (f a)) r0+{-# INLINE map #-}++-- | Returns a FoldList with the given item repeated @n@ times.+replicate :: Int -> a -> FoldList a+replicate n a = fromFoldable (L.replicate n a)+{-# INLINE replicate #-}++-- | Executes the given monadic action the given number of times and returns+-- a FoldList of the results.+replicateM :: Monad m => Int -> m a -> m (FoldList a)+replicateM n = M.liftM fromFoldable . M.replicateM n+{-# INLINE replicateM #-}++instance Show a => Show (FoldList a) where+ show l = "[" ++ intercalate ", " (F.foldr go [] l) ++ "]"+ where+ go a xs = show a:xs++instance Functor FoldList where+ fmap = map+ {-# INLINE fmap #-}++instance F.Foldable FoldList where+ foldMap f (FoldList l) = l (\r a -> r <> f a) mempty+ {-# INLINE foldMap #-}++ foldl' f r (FoldList l) = l f r+ {-# INLINE foldl' #-}++instance T.Traversable FoldList where+ sequenceA (FoldList f) =+ f (\l a -> go <$> l <*> a) (pure (FoldList (\_ r -> r)))+ where+ go (FoldList xs) x = FoldList (\k r -> k (xs k r) x)+ {-# INLINE go #-}+ {-# INLINE sequenceA #-}++instance Eq a => Eq (FoldList a) where+ l == r = F.toList l == F.toList r++instance NFData a => NFData (FoldList a) where+ rnf (FoldList l) = l (\() a -> rnf a `seq` ()) ()++instance Hashable a => Hashable (FoldList a) where+ hashWithSalt s (FoldList l) = l hashWithSalt s
+ src/Pinch/Internal/Generic.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Implements support for automatically deriving Pinchable instances for types+-- that implement @Generic@ and follow a specific pattern.+--+module Pinch.Internal.Generic+ ( Field(..)+ , getField+ , putField+ , field++ , Enumeration(..)+ , enum++ , Void(..)+ ) where+++#if __GLASGOW_HASKELL__ < 709+import Data.Foldable (Foldable)+import Data.Monoid (Monoid)+import Data.Traversable (Traversable)+#endif++import Control.Applicative+import Control.DeepSeq (NFData)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import GHC.Generics+import GHC.TypeLits++import qualified Data.HashMap.Strict as HM++import Pinch.Internal.Pinchable+import Pinch.Internal.TType+import Pinch.Internal.Value (Value (..))+++-- | Implemented by TType tags whose values know how to combine.+class Combinable t where+ combine :: Value t -> Value t -> Value t++instance Combinable TStruct where+ combine (VStruct as) (VStruct bs) = VStruct $ as `HM.union` bs+++instance OVERLAP GPinchable a => GPinchable (M1 i c a) where+ type GTag (M1 i c a) = GTag a+ gPinch = gPinch . unM1+ gUnpinch = fmap M1 . gUnpinch+++-- Adds the name of the data type to the error message.+instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where+ type GTag (D1 d a) = GTag a+ gPinch = gPinch . unM1+ gUnpinch v =+ parserCatch (gUnpinch v)+ (\msg -> fail $ "Failed to read '" ++ name ++ "': " ++ msg)+ (return . M1)+ where+ name = datatypeName (undefined :: D1 d a b)++instance+ ( GPinchable a+ , GPinchable b+ , GTag a ~ GTag b+ , Combinable (GTag a)+ ) => GPinchable (a :*: b) where+ type GTag (a :*: b) = GTag a+ gPinch (a :*: b) = gPinch a `combine` gPinch b+ gUnpinch m = (:*:) <$> gUnpinch m <*> gUnpinch m++instance+ ( GPinchable a+ , GPinchable b+ , GTag a ~ GTag b+ ) => GPinchable (a :+: b) where+ type GTag (a :+: b) = GTag a+ gPinch (L1 a) = gPinch a+ gPinch (R1 b) = gPinch b+ gUnpinch m = L1 <$> gUnpinch m <|> R1 <$> gUnpinch m++------------------------------------------------------------------------------++-- | Fields of data types that represent structs, unions, and exceptions+-- should be wrapped inside 'Field' and tagged with the field identifier.+--+-- > data Foo = Foo (Field 1 Text) (Field 2 (Maybe Int32)) deriving Generic+-- > instance Pinchable Foo+--+-- > data A = A (Field 1 Int32) | B (Field 2 Text) deriving Generic+-- > instance Pinchable Foo+--+-- Fields which hold @Maybe@ values are treated as optional. All fields values+-- must be 'Pinchable' to automatically derive a @Pinchable@ instance for the+-- new data type.+newtype Field (n :: Nat) a = Field a+ deriving+ (Bounded, Eq, Enum, Foldable, Functor, Generic, Monoid, NFData, Ord, Show,+ Traversable, Typeable)++-- | Gets the current value of a field.+--+-- > let Foo a' _ = {- ... -}+-- > a = getField a'+getField :: Field n a -> a+getField (Field a) = a++-- | Puts a value inside a field.+--+-- > Foo (putField "Hello") (putField (Just 42))+putField :: a -> Field n a+putField = Field++-- | A lens on @Field@ wrappers for use with the lens library.+--+-- > person & name . field .~ "new value"+--+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)+ => GPinchable (K1 i (Field n a)) where+ type GTag (K1 i (Field n a)) = TStruct+ gPinch (K1 (Field a)) = struct [n .= a]+ where+ n = fromIntegral $ natVal (Proxy :: Proxy n)++ gUnpinch m = K1 . Field <$> m .: n+ where+ n = fromIntegral $ natVal (Proxy :: Proxy n)++instance+ (Pinchable a, KnownNat n)+ => GPinchable (K1 i (Field n (Maybe a))) where+ type GTag (K1 i (Field n (Maybe a))) = TStruct+ gPinch (K1 (Field a)) = struct [n ?= a]+ where+ n = fromIntegral $ natVal (Proxy :: Proxy n)++ gUnpinch m = K1 . Field <$> m .:? n+ where+ n = fromIntegral $ natVal (Proxy :: Proxy n)++------------------------------------------------------------------------------++-- | Data types that represent Thrift enums must have one constructor for each+-- enum item accepting an 'Enumeration' object tagged with the corresponding+-- enum value.+--+-- > data Role = RoleUser (Enumeration 1) | RoleAdmin (Enumeration 2)+-- > deriving Generic+-- > instance Pinchable Role+data Enumeration (n :: Nat) = Enumeration+ deriving+ (Eq, Generic, Ord, Show, Typeable)++instance NFData (Enumeration n)++-- | Convenience function to construct 'Enumeration' objects.+--+-- > let role = RoleUser enum+enum :: Enumeration n+enum = Enumeration++instance KnownNat n => GPinchable (K1 i (Enumeration n)) where+ type GTag (K1 i (Enumeration n)) = TEnum+ gPinch (K1 Enumeration) = VInt32 . fromIntegral $ natVal (Proxy :: Proxy n)+ gUnpinch (VInt32 i)+ | i == val = return (K1 Enumeration)+ | 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++------------------------------------------------------------------------------++-- | Represents a @void@ result for methods.+--+-- This should be used as an element in a response union along with 'Field'+-- tags.+--+-- For a method,+--+-- > void setValue(..) throws+-- > (1: ValueAlreadyExists alreadyExists,+-- > 2: InternalError internalError)+--+-- Something similar to the following can be used.+--+-- > data SetValueResponse+-- > = SetValueAlreadyExists (Field 1 ValueAlreadyExists)+-- > | SetValueInternalError (Field 2 InternalError)+-- > | SetValueSuccess Void+-- > deriving (Generic)+-- >+-- > instance Pinchable SetValueResponse+data Void = Void+ deriving+ (Eq, Generic, Ord, Show, Typeable)++instance GPinchable (K1 i Void) where+ type GTag (K1 i Void) = TStruct++ gPinch (K1 Void) = struct []++ -- If the map isn't empty, there's probably an exception in there.+ gUnpinch (VStruct m) | HM.null m = return $ K1 Void+ gUnpinch x = fail $+ "Failed to read response. Expected void, got: " ++ show x
+ src/Pinch/Internal/Message.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+-- |+-- Module : Pinch.Internal.Message+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Message wrapper for Thrift payloads. Normal Thrift requests sent over the+-- wire are wrapped inside a message envelope that contains information about+-- the method being called, the type of message, etc. This information is+-- essential for the RPC system to function.+module Pinch.Internal.Message+ ( Message(..)+ , MessageType(..)+ ) where++import Control.DeepSeq (NFData)+import Data.Data (Data)+import Data.Int (Int32)+import Data.Text (Text)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import Pinch.Internal.TType (TStruct)+import Pinch.Internal.Value (Value)++-- | Type of message being sent.+data MessageType+ = Call+ -- ^ A call to a specific method.+ --+ -- The message body is the request arguments struct.+ | Reply+ -- ^ Response to a call.+ --+ -- The message body is the response union.+ | Exception+ -- ^ Failure to make a call.+ --+ -- Note: This message type is /not/ used for exceptions that are defined+ -- under the @throws@ clause of a method. Those exceptions are part of the+ -- response union of the method and are received in a @Reply@. This+ -- message type is used for Thrift-level failures.+ | Oneway+ -- ^ One-way call that expects no response.+ deriving (Show, Eq, Data, Typeable, Generic)++instance NFData MessageType+++-- | Message envelope for Thrift payloads.+data Message = Message+ { messageName :: !Text+ -- ^ Name of the method to which this message is targeted.+ , messageType :: !MessageType+ -- ^ Type of the message.+ , messageId :: !Int32+ -- ^ Sequence ID of the message.+ --+ -- If the clients expect to receive out-of-order responses, they may use+ -- the message ID to map responses back to their corresponding requests.+ -- If the client does not expect out-of-order responses, they are free to+ -- use the same message ID for all messages.+ --+ -- The server's contract regarding message IDs is that all responses must+ -- have the same message ID as their corresponding requests.+ , messagePayload :: !(Value TStruct)+ -- ^ Contents of the message.+ }+ deriving (Show, Eq, Typeable, Generic)++instance NFData Message
+ src/Pinch/Internal/Parser.hs view
@@ -0,0 +1,175 @@+{-# 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++ , int8+ , int16+ , int32+ , int64+ , double+ , 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 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 #-}+++-- | @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 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 64-bit floating point number and advances the parser.+double :: Parser Double+double = int64 >>= \i -> return (ST.runST (cast i))+{-# INLINE double #-}+++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 #-}
+ src/Pinch/Internal/Pinchable.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module : Pinch.Internal.Pinchable+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Provides the core @Pinchable@ typeclass and the @GPinchable@ typeclass used+-- to derive instances automatically.+--+module Pinch.Internal.Pinchable+ ( Pinchable(..)++ , (.=)+ , (?=)+ , struct+ , union+ , FieldPair++ , (.:)+ , (.:?)++ , GPinchable(..)+ , genericPinch+ , genericUnpinch++ , Parser+ , runParser+ , 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)+import Data.List (foldl')+import Data.Text (Text)+import Data.Typeable ((:~:) (..))+import Data.Vector (Vector)+import GHC.Generics (Generic, Rep)++import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Vector as V+import qualified GHC.Generics as G++import Pinch.Internal.Pinchable.Parser+import Pinch.Internal.TType+import Pinch.Internal.Value++import qualified Pinch.Internal.FoldList as FL++-- | Implementation of 'pinch' based on 'GPinchable'.+genericPinch+ :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a))+genericPinch = gPinch . G.from++-- | Implementation of 'unpinch' based on 'GPinchable'.+genericUnpinch+ :: (Generic a, GPinchable (Rep a)) => Value (GTag (Rep a)) -> Parser a+genericUnpinch = fmap G.to . gUnpinch+++-- | GPinchable is used to impelment support for automatically deriving+-- instances of Pinchable via generics.+class IsTType (GTag f) => GPinchable (f :: * -> *) where+ -- | 'TType' tag to use for objects of this type.+ type GTag f++ -- | Converts a generic representation of a value into a 'Value'.+ gPinch :: f a -> Value (GTag f)++ -- | Converts a 'Value' back into the generic representation of the+ -- object.+ gUnpinch :: Value (GTag f) -> Parser (f a)+++-- | The Pinchable type class is implemented by types that can be sent or+-- received over the wire as Thrift payloads.+class IsTType (Tag a) => Pinchable a where+ -- | 'TType' tag for this type.+ --+ -- For most custom types, this will be 'TStruct', 'TUnion', or+ -- 'TException'. For enums, it will be 'TEnum'. If the instance+ -- automatically derived with use of @Generic@, this is not required+ -- because it is automatically determined by use of @Field@ or+ -- @Enumeration@.+ type Tag a+ type Tag a = GTag (Rep a)++ -- | Convert an @a@ into a 'Value'.+ --+ -- For structs, 'struct', '.=', and '?=' may be used to construct+ -- 'Value' objects tagged with 'TStruct'.+ pinch :: a -> Value (Tag a)++ -- | Read a 'Value' back into an @a@.+ --+ -- For structs, '.:' and '.:?' may be used to retrieve field values.+ unpinch :: Value (Tag a) -> Parser a++ default pinch+ :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a))+ pinch = genericPinch++ default unpinch+ :: (Generic a, GPinchable (Rep a))+ => Value (GTag (Rep a)) -> Parser a+ unpinch = genericUnpinch+++------------------------------------------------------------------------------++-- | A pair of field identifier and maybe a value stored in the field. If the+-- value is absent, the field will be ignored.+type FieldPair = (Int16, Maybe SomeValue)++-- | Construct a 'FieldPair' from a field identifier and a 'Pinchable' value.+(.=) :: Pinchable a => Int16 -> a -> FieldPair+fid .= value = (fid, Just $ SomeValue (pinch value))++-- | Construct a 'FieldPair' from a field identifier and an optional+-- 'Pinchable' value.+(?=) :: Pinchable a => Int16 -> Maybe a -> FieldPair+fid ?= value = (fid, SomeValue . pinch <$> value)++-- | Construct a 'Value' tagged with a 'TStruct' from the given key-value+-- pairs. Optional fields whose values were omitted will be ignored.+--+-- > struct [1 .= ("Hello" :: Text), 2 .= (42 :: Int16)]+struct :: [FieldPair] -> Value TStruct+struct = VStruct . foldl' go HM.empty+ where+ go m (_, Nothing) = m+ go m (k, Just v) = HM.insert k v m++-- | Constructs a 'Value' tagged with 'TUnion'.+--+-- > union 1 ("foo" :: ByteString)+--+union :: Pinchable a => Int16 -> a -> Value TUnion+union k v = VStruct (HM.singleton k (SomeValue $ pinch v))++-- | Given a field ID and a @Value TStruct@, get the value stored in the+-- struct under that field ID. The lookup fails if the field is absent or if+-- it's not the same type as expected by this call's context.+(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser a+(VStruct items) .: fieldId = do+ SomeValue someValue <- note ("Field " ++ show fieldId ++ " is absent.")+ $ fieldId `HM.lookup` items+ (value :: Value (Tag a)) <-+ note ("Field " ++ show fieldId ++ " has the incorrect type. " +++ "Expected '" ++ show (ttype :: TType (Tag a)) ++ "' but " +++ "got '" ++ show (valueTType someValue) ++ "'")+ $ castValue someValue+ unpinch value+ where+ note msg m = case m of+ Nothing -> fail msg+ Just v -> return v++-- | Given a field ID and a @Value TStruct@, get the optional value stored in+-- the struct under the given field ID. The value returned is @Nothing@ if it+-- was absent or the wrong type. The lookup fails only if the value retrieved+-- fails to 'unpinch'.+(.:?) :: forall a. Pinchable a+ => Value TStruct -> Int16 -> Parser (Maybe a)+(VStruct items) .:? fieldId =+ case value of+ Nothing -> return Nothing+ Just v -> Just <$> unpinch v+ where+ value :: Maybe (Value (Tag a))+ value = fieldId `HM.lookup` items >>= \(SomeValue v) -> castValue v++------------------------------------------------------------------------------++-- | Helper to 'unpinch' values by matching TTypes.+checkedUnpinch+ :: forall a b. (Pinchable a, IsTType b)+ => Value b -> Parser a+checkedUnpinch = case ttypeEqT of+ Nothing -> const . fail $+ "Type mismatch. Expected " ++ show ttypeA ++ ". Got " ++ show ttypeB+ Just (Refl :: Tag a :~: b) -> unpinch+ where+ ttypeA = ttype :: TType (Tag a)+ ttypeB = ttype :: TType b++-- | Helper to 'pinch' maps.+pinchMap+ :: (Pinchable k, Pinchable v)+ => (forall r. (r -> k -> v -> r) -> r -> m k v -> r)+ -- ^ @foldlWithKey@+ -> m k v+ -> Value TMap+pinchMap foldlWithKey = VMap . FL.map go . FL.fromMap foldlWithKey+ where+ go (!k, !v) = MapItem (pinch k) (pinch v)++unpinchMap+ :: (Pinchable k, Pinchable v)+ => (k -> v -> m -> m) -> m -> Value a -> Parser m+unpinchMap mapInsert mapEmpty (VMap xs) =+ FL.foldl' (\m (!k, !v) -> mapInsert k v m) mapEmpty <$> FL.mapM go xs+ where+ go (MapItem k v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v+unpinchMap _ _ x = fail $ "Failed to read map. Got " ++ show x++instance IsTType a => Pinchable (Value a) where+ type Tag (Value a) = a+ pinch = id+ unpinch = return++instance Pinchable ByteString where+ 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++ pinch = VList . FL.map pinch . FL.fromFoldable++ 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++ 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+ , Hashable k+ , Pinchable k+ , Pinchable v+ ) => Pinchable (HM.HashMap k v) where+ type Tag (HM.HashMap k v) = TMap+ pinch = pinchMap HM.foldlWithKey'+ unpinch = unpinchMap HM.insert HM.empty++instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where+ type Tag (M.Map k v) = TMap+ pinch = pinchMap M.foldlWithKey'+ unpinch = unpinchMap M.insert M.empty++instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where+ type Tag (HS.HashSet a) = TSet+ pinch = VSet . FL.map pinch . FL.fromFoldable++ 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+ pinch = VSet . FL.map pinch . FL.fromFoldable++ 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
+ src/Pinch/Internal/Pinchable/Parser.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE Rank2Types #-}+-- |+-- Module : Pinch.Internal.Pinchable.Parser+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Implements a continuation based version of the @Either e@ monad.+--+module Pinch.Internal.Pinchable.Parser+ ( Parser+ , runParser+ , parserCatch+ ) where++import Control.Applicative+import Control.Monad++-- | Failure continuation. Called with the failure message.+type Failure r = String -> r+type Success a r = a -> r+-- ^ Success continuation. Called with the result.++-- | A simple continuation-based parser.+--+-- This is just @Either e a@ in continuation-passing style.+newtype Parser a = Parser+ { unParser :: forall r.+ Failure r -- Failure continuation+ -> Success a r -- Success continuation+ -> r+ } -- TODO can probably track position in the struct++instance Functor Parser where+ {-# INLINE fmap #-}+ fmap f (Parser g) = Parser $ \kFail kSucc -> g kFail (kSucc . f)++instance Applicative Parser where+ {-# INLINE pure #-}+ pure a = Parser $ \_ kSucc -> kSucc a++ {-# INLINE (<*>) #-}+ Parser f' <*> Parser a' =+ Parser $ \kFail kSuccB ->+ f' kFail $ \f ->+ a' kFail $ \a ->+ kSuccB (f a)++instance Alternative Parser where+ {-# INLINE empty #-}+ empty = Parser $ \kFail _ -> kFail "Alternative.empty"++ {-# INLINE (<|>) #-}+ Parser l' <|> Parser r' =+ Parser $ \kFail kSucc ->+ l' (\_ -> r' kFail kSucc) kSucc++instance Monad Parser where+ {-# INLINE fail #-}+ fail msg = Parser $ \kFail _ -> kFail msg++ {-# INLINE return #-}+ return = pure++ {-# INLINE (>>) #-}+ (>>) = (*>)++ {-# INLINE (>>=) #-}+ Parser a' >>= k =+ Parser $ \kFail kSuccB ->+ a' kFail $ \a ->+ unParser (k a) kFail kSuccB++instance MonadPlus Parser where+ {-# INLINE mzero #-}+ mzero = empty++ {-# INLINE mplus #-}+ mplus = (<|>)++-- | Run a @Parser@ and return the result inside an @Either@.+runParser :: Parser a -> Either String a+runParser p = unParser p Left Right++-- | Allows handling parse errors.+parserCatch+ :: Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b+parserCatch = unParser+{-# INLINE parserCatch #-}
+ src/Pinch/Internal/TType.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module : Pinch.Internal.TType+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Defines the different types Thrift supports at the protocol level.+--+module Pinch.Internal.TType+ (+ -- * TType++ TType(..)+ , IsTType(..)+ , SomeTType(..)++ , ttypeEquality+ , ttypeEqT++ -- * Tags++ , TBool+ , TByte+ , TDouble+ , TInt16+ , TInt32+ , TEnum+ , TInt64+ , TBinary+ , TText+ , TStruct+ , TUnion+ , TException+ , TMap+ , TSet+ , TList+ ) where++import Data.Hashable (Hashable (..))+import Data.Typeable ((:~:) (..), Typeable)++-- | > bool+data TBool deriving (Typeable)++-- | > byte+data TByte deriving (Typeable)++-- | > double+data TDouble deriving (Typeable)++-- | > i16+data TInt16 deriving (Typeable)++-- | > i32+data TInt32 deriving (Typeable)++-- | > enum+type TEnum = TInt32++-- | > i64+data TInt64 deriving (Typeable)++-- | > binary+data TBinary deriving (Typeable)++-- | > string+type TText = TBinary++-- | > struct+data TStruct deriving (Typeable)++-- | > union+type TUnion = TStruct++-- | > exception+type TException = TStruct++-- | > map<k, v>+data TMap deriving (Typeable)++-- | > set<x>+data TSet deriving (Typeable)++-- | > list<x>+data TList deriving (Typeable)+++-- | Represents the type of a Thrift value.+--+-- Objects of this type are tagged with one of the TType tags, so this type+-- also acts as a singleton on the TTypes. It allows writing code that can+-- enforce properties about the TType of values at compile time.+data TType a where+ TBool :: TType TBool -- 2+ TByte :: TType TByte -- 3+ TDouble :: TType TDouble -- 4+ TInt16 :: TType TInt16 -- 6+ TInt32 :: TType TInt32 -- 8+ TInt64 :: TType TInt64 -- 10+ TBinary :: TType TBinary -- 11+ TStruct :: TType TStruct -- 12+ TMap :: TType TMap -- 13+ TSet :: TType TSet -- 14+ TList :: TType TList -- 15+ deriving (Typeable)++deriving instance Show (TType a)+deriving instance Eq (TType a)++instance Hashable (TType a) where+ hashWithSalt s TBool = s `hashWithSalt` (0 :: Int)+ hashWithSalt s TByte = s `hashWithSalt` (1 :: Int)+ hashWithSalt s TDouble = s `hashWithSalt` (2 :: Int)+ hashWithSalt s TInt16 = s `hashWithSalt` (3 :: Int)+ hashWithSalt s TInt32 = s `hashWithSalt` (4 :: Int)+ hashWithSalt s TInt64 = s `hashWithSalt` (5 :: Int)+ hashWithSalt s TBinary = s `hashWithSalt` (6 :: Int)+ hashWithSalt s TStruct = s `hashWithSalt` (7 :: Int)+ hashWithSalt s TMap = s `hashWithSalt` (8 :: Int)+ hashWithSalt s TSet = s `hashWithSalt` (9 :: Int)+ hashWithSalt s TList = s `hashWithSalt` (10 :: Int)+++-- | Typeclass used to map type-leve TTypes into 'TType' objects. All TType+-- tags are instances of this class.+class Typeable a => IsTType a where+ -- | Based on the context in which this is used, it will automatically+ -- return the corresponding 'TType' object.+ ttype :: TType a+++instance IsTType TBool where ttype = TBool+instance IsTType TByte where ttype = TByte+instance IsTType TDouble where ttype = TDouble+instance IsTType TInt16 where ttype = TInt16+instance IsTType TInt32 where ttype = TInt32+instance IsTType TInt64 where ttype = TInt64+instance IsTType TBinary where ttype = TBinary+instance IsTType TStruct where ttype = TStruct+instance IsTType TMap where ttype = TMap+instance IsTType TSet where ttype = TSet+instance IsTType TList where ttype = TList+++-- | Used when the 'TType' for something is not known at compile time.+-- Typically, this will be pattern matched inside a case statement and code+-- that depends on the TType will be go there.+data SomeTType where+ SomeTType :: forall a. IsTType a => TType a -> SomeTType+ deriving Typeable++deriving instance Show SomeTType++-- | Witness the equality of two ttypes.+ttypeEquality :: TType a -> TType b -> Maybe (a :~: b)+ttypeEquality TBool TBool = Just Refl+ttypeEquality TByte TByte = Just Refl+ttypeEquality TDouble TDouble = Just Refl+ttypeEquality TInt16 TInt16 = Just Refl+ttypeEquality TInt32 TInt32 = Just Refl+ttypeEquality TInt64 TInt64 = Just Refl+ttypeEquality TBinary TBinary = Just Refl+ttypeEquality TStruct TStruct = Just Refl+ttypeEquality TMap TMap = Just Refl+ttypeEquality TSet TSet = Just Refl+ttypeEquality TList TList = Just Refl+ttypeEquality _ _ = Nothing+{-# INLINE ttypeEquality #-}++-- | Witness the equality of two TTypes.+--+-- Implicit version of @ttypeEquality@.+ttypeEqT :: forall a b. (IsTType a, IsTType b) => Maybe (a :~: b)+ttypeEqT = ttypeEquality ttype ttype+{-# INLINE ttypeEqT #-}
+ src/Pinch/Internal/Value.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module : Pinch.Internal.Value+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- This module defines an intermediate representation for Thrift values and+-- functions to work with the intermediate representation.+module Pinch.Internal.Value+ ( Value(..)+ , MapItem(..)+ , SomeValue(..)+ , castValue+ , valueTType+ ) where++import Control.DeepSeq (NFData (..))+import Data.ByteString (ByteString)+import Data.Hashable (Hashable (..))+import Data.HashMap.Strict (HashMap)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List (intercalate)+import Data.Typeable ((:~:) (..), Typeable)++import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import Pinch.Internal.FoldList (FoldList)+import Pinch.Internal.TType++-- | A single item in a map+data MapItem k v = MapItem !(Value k) !(Value v)+ deriving (Eq, Typeable)++instance NFData (MapItem k v) where+ rnf (MapItem k v) = rnf k `seq` rnf v `seq` ()++instance Hashable (MapItem k v) where+ hashWithSalt s (MapItem k v) = s `hashWithSalt` k `hashWithSalt` v++instance Show (MapItem k v) where+ show (MapItem k v) = show k ++ ": " ++ show v++-- | @Value@ maps directly to serialized representation of Thrift types. It+-- contains about as much information as what gets sent over the wire.+-- @Value@ objects are tagged with different 'TType' values to indicate the+-- type of the value.+--+-- Typical usage will not involve accessing the constructors for this type.+-- 'Pinch.Pinchable.Pinchable' must be used to construct 'Value' objects or+-- convert them back to original types.+data Value a where+ VBool :: !Bool -> Value TBool+ VByte :: !Int8 -> Value TByte+ VDouble :: !Double -> Value TDouble+ VInt16 :: !Int16 -> Value TInt16+ VInt32 :: !Int32 -> Value TInt32+ VInt64 :: !Int64 -> Value TInt64+ VBinary :: !ByteString -> Value TBinary+ VStruct :: !(HashMap Int16 SomeValue) -> Value TStruct++ VMap :: forall k v. (IsTType k, IsTType v)+ => !(FoldList (MapItem k v)) -> Value TMap+ VSet :: forall a. IsTType a => !(FoldList (Value a)) -> Value TSet+ VList :: forall a. IsTType a => !(FoldList (Value a)) -> Value TList+ deriving Typeable++instance Show (Value a) where+ show (VBool x) = show x+ show (VByte x) = show x+ show (VDouble x) = show x+ show (VInt16 x) = "i16(" ++ show x ++ ")"+ show (VInt32 x) = "i32(" ++ show x ++ ")"+ show (VInt64 x) = "i64(" ++ show x ++ ")"+ show (VBinary x) = show x++ show (VStruct x) = "{" ++ s ++ "}"+ where+ s = intercalate ", " (M.foldlWithKey' go [] x)+ go xs i (SomeValue val) = (show i ++ ": " ++ show val):xs++ show (VMap x) = show x+ show (VSet x) = show x+ show (VList x) = show x++instance Eq (Value a) where+ VBool a == VBool b = a == b+ VByte a == VByte b = a == b+ VDouble a == VDouble b = a == b+ VInt16 a == VInt16 b = a == b+ VInt32 a == VInt32 b = a == b+ VInt64 a == VInt64 b = a == b+ VBinary a == VBinary b = a == b+ VStruct a == VStruct b = a == b++ VList as == VList bs = areEqual1 as bs+ VMap as == VMap bs = areEqual2 (toMap as) (toMap bs)+ where+ toMap = F.foldl' (\m (MapItem k v) -> M.insert k v m) M.empty+ VSet as == VSet bs = areEqual1 (toSet as) (toSet bs)+ _ == _ = False++toSet :: forall f x. (F.Foldable f, Hashable x, Eq x) => f x -> S.HashSet x+toSet = F.foldl' (flip S.insert) S.empty++instance NFData (Value a) where+ rnf (VBool a) = rnf a+ rnf (VByte a) = rnf a+ rnf (VDouble a) = rnf a+ rnf (VInt16 a) = rnf a+ rnf (VInt32 a) = rnf a+ rnf (VInt64 a) = rnf a+ rnf (VBinary a) = rnf a+ rnf (VStruct a) = rnf a+ rnf (VMap as) = rnf as+ rnf (VSet as) = rnf as+ rnf (VList as) = rnf as++-- | 'SomeValue' holds any value, regardless of type. This may be used when+-- the type of the value is not necessarily known at compile time. Typically,+-- this will be pattern matched on and code that depends on the value's+-- 'TType' will go inside the scope of the match.+data SomeValue where+ SomeValue :: (IsTType a) => !(Value a) -> SomeValue+ deriving Typeable++deriving instance Show SomeValue++instance Eq SomeValue where+ SomeValue a == SomeValue b = areEqual a b++instance NFData SomeValue where+ rnf (SomeValue a) = rnf a++-- | Safely attempt to cast a Value into another.+castValue :: forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b)+castValue v = case ttypeEqT of+ Just (Refl :: a :~: b) -> Just v+ Nothing -> Nothing+{-# INLINE castValue #-}++-- | Get the 'TType' of a 'Value'.+valueTType :: IsTType a => Value a -> TType a+valueTType _ = ttype+{-# INLINE valueTType #-}++areEqual+ :: forall a b. (IsTType a, IsTType b) => Value a -> Value b -> Bool+areEqual l r = case ttypeEqT of+ Just (Refl :: a :~: b) -> l == r+ Nothing -> False+{-# INLINE areEqual #-}++areEqual1+ :: forall a b f. (IsTType a, IsTType b, Eq (f (Value a)))+ => f (Value a) -> f (Value b) -> Bool+areEqual1 l r = case ttypeEqT of+ Just (Refl :: a :~: b) -> l == r+ Nothing -> False+{-# INLINE areEqual1 #-}++areEqual2+ :: forall f k1 v1 k2 v2.+ ( IsTType k1, IsTType v1, IsTType k2, IsTType v2+ , Eq (f (Value k1) (Value v1))+ ) => f (Value k1) (Value v1) -> f (Value k2) (Value v2) -> Bool+areEqual2 l r = case ttypeEqT of+ Just (Refl :: k1 :~: k2) -> case ttypeEqT of+ Just (Refl :: v1 :~: v2) -> l == r+ Nothing -> False+ Nothing -> False+{-# INLINE areEqual2 #-}++instance Hashable (Value a) where+ hashWithSalt s a = case a of+ VBinary x -> s `hashWithSalt` (0 :: Int) `hashWithSalt` x+ VBool x -> s `hashWithSalt` (1 :: Int) `hashWithSalt` x+ VByte x -> s `hashWithSalt` (2 :: Int) `hashWithSalt` x+ VDouble x -> s `hashWithSalt` (3 :: Int) `hashWithSalt` x+ VInt16 x -> s `hashWithSalt` (4 :: Int) `hashWithSalt` x+ VInt32 x -> s `hashWithSalt` (5 :: Int) `hashWithSalt` x+ VInt64 x -> s `hashWithSalt` (6 :: Int) `hashWithSalt` x+ VList x -> s `hashWithSalt` (7 :: Int) `hashWithSalt` x+ VMap x -> s `hashWithSalt` (8 :: Int) `hashWithSalt` x+ VSet x -> s `hashWithSalt` (9 :: Int) `hashWithSalt` x++ VStruct fields ->+ M.foldlWithKey' (\s' k v -> s' `hashWithSalt` k `hashWithSalt` v)+ (s `hashWithSalt` (10 :: Int))+ fields+++instance Hashable SomeValue where+ hashWithSalt s (SomeValue v) = hashWithSalt s v
+ src/Pinch/Protocol.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module : Pinch.Protocol+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Protocols in Pinch only need to know how to serialize and deserialize+-- 'Value' objects. Types that want to be serialized into/from Thrift payloads+-- define how to convert them to/from 'Value' objects via+-- 'Pinch.Pinchable.Pinchable'.+module Pinch.Protocol+ ( Protocol(..)+ ) where++import Data.ByteString (ByteString)++import Pinch.Internal.Builder (Builder)+import Pinch.Internal.Message (Message)+import Pinch.Internal.TType (IsTType)+import Pinch.Internal.Value (Value)++-- | Protocols define a specific way to convert values into binary and back.+data Protocol = Protocol+ { serializeValue :: forall a. IsTType a => Value a -> Builder+ -- ^ Serializes a 'Value' into a ByteString builder.+ --+ -- Returns a @Builder@ and the total length of the serialized content.+ , serializeMessage :: Message -> Builder+ -- ^ Serializes a 'Message' and its payload into a ByteString builder.+ --+ -- Returns a @Builder@ and the total length of the serialized content.++ , deserializeValue+ :: forall a. IsTType a => ByteString -> Either String (Value a)+ -- ^ Reads a 'Value' from a ByteString.+ , deserializeMessage :: ByteString -> Either String Message+ -- ^ Reads a 'Message' and its payload from a ByteString.+ }
+ src/Pinch/Protocol/Binary.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Pinch.Protocol.Binary+-- Copyright : (c) Abhinav Gupta 2015+-- License : BSD3+--+-- Maintainer : Abhinav Gupta <mail@abhinavg.net>+-- Stability : experimental+--+-- Implements the Thrift Binary Protocol as a 'Protocol'.+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 Pinch.Internal.Builder (Builder)+import Pinch.Internal.Message+import Pinch.Internal.Parser (Parser, 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.+binaryProtocol :: Protocol+binaryProtocol = Protocol+ { serializeValue = binarySerialize+ , deserializeValue = binaryDeserialize ttype+ , serializeMessage = binarySerializeMessage+ , deserializeMessage = binaryDeserializeMessage+ }++------------------------------------------------------------------------------++binarySerializeMessage :: Message -> Builder+binarySerializeMessage msg =+ string (TE.encodeUtf8 $ messageName msg) <>+ BB.int8 (messageCode (messageType msg)) <> BB.int32BE (messageId msg) <>+ binarySerialize (messagePayload msg)++binaryDeserializeMessage :: ByteString -> Either String Message+binaryDeserializeMessage = runParser binaryMessageParser++binaryMessageParser :: Parser Message+binaryMessageParser = do+ size <- P.int32+ if size < 0+ then parseStrict size+ else parseNonStrict size+ where+ -- versionAndType:4 name~4 seqid:4 payload+ -- versionAndType = version:2 0x00 type:1+ parseStrict versionAndType = do+ unless (version == 1) $+ fail $ "Unsupported version: " ++ show version+ Message+ <$> TE.decodeUtf8 <$> (P.int32 >>= P.take . fromIntegral)+ <*> typ+ <*> P.int32+ <*> binaryParser ttype+ where+ version = (0x7fff0000 .&. versionAndType) `shiftR` 16++ code = fromIntegral $ 0x00ff .&. versionAndType+ typ = case fromMessageCode code of+ Nothing -> fail $ "Unknown message type: " ++ show code+ Just t -> return t++ -- name~4 type:1 seqid:4 payload+ parseNonStrict nameLength =+ Message+ <$> TE.decodeUtf8 <$> P.take (fromIntegral nameLength)+ <*> parseMessageType+ <*> P.int32+ <*> binaryParser ttype+++parseMessageType :: Parser MessageType+parseMessageType = P.int8 >>= \code -> case fromMessageCode code of+ Nothing -> fail $ "Unknown message type: " ++ show code+ Just t -> return t++------------------------------------------------------------------------------++binaryDeserialize :: TType a -> ByteString -> Either String (Value a)+binaryDeserialize t = runParser (binaryParser t)++binaryParser :: TType a -> Parser (Value a)+binaryParser typ = case typ of+ TBool -> parseBool+ TByte -> parseByte+ TDouble -> parseDouble+ TInt16 -> parseInt16+ TInt32 -> parseInt32+ TInt64 -> parseInt64+ TBinary -> parseBinary+ TStruct -> parseStruct+ TMap -> parseMap+ TSet -> parseSet+ TList -> parseList++getTType :: Int8 -> Parser SomeTType+getTType code =+ maybe (fail $ "Unknown TType: " ++ show code) return $ fromTypeCode code++parseTType :: Parser SomeTType+parseTType = P.int8 >>= getTType++parseBool :: Parser (Value TBool)+parseBool = VBool . (== 1) <$> P.int8++parseByte :: Parser (Value TByte)+parseByte = VByte <$> P.int8++parseDouble :: Parser (Value TDouble)+parseDouble = VDouble <$> P.double++parseInt16 :: Parser (Value TInt16)+parseInt16 = VInt16 <$> P.int16++parseInt32 :: Parser (Value TInt32)+parseInt32 = VInt32 <$> P.int32++parseInt64 :: Parser (Value TInt64)+parseInt64 = VInt64 <$> P.int64++parseBinary :: Parser (Value TBinary)+parseBinary = VBinary <$> (P.int32 >>= P.take . fromIntegral)+++parseMap :: Parser (Value TMap)+parseMap = do+ ktype' <- parseTType+ vtype' <- parseTType+ count <- P.int32++ case (ktype', vtype') of+ (SomeTType ktype, SomeTType vtype) -> do+ items <- FL.replicateM (fromIntegral count) $+ MapItem <$> binaryParser ktype+ <*> binaryParser vtype+ return $ VMap items+++parseSet :: Parser (Value TSet)+parseSet = do+ vtype' <- parseTType+ count <- P.int32++ case vtype' of+ SomeTType vtype ->+ VSet <$> FL.replicateM (fromIntegral count) (binaryParser vtype)+++parseList :: Parser (Value TList)+parseList = do+ vtype' <- parseTType+ count <- P.int32++ case vtype' of+ SomeTType vtype ->+ VList <$> FL.replicateM (fromIntegral count) (binaryParser vtype)+++parseStruct :: Parser (Value TStruct)+parseStruct = P.int8 >>= loop M.empty+ where+ loop :: HashMap Int16 SomeValue -> Int8 -> Parser (Value TStruct)+ loop fields 0 = return $ VStruct fields+ loop fields code = do+ vtype' <- getTType code+ fieldId <- P.int16+ case vtype' of+ SomeTType vtype -> do+ value <- SomeValue <$> binaryParser vtype+ loop (M.insert fieldId value fields) =<< P.int8+++------------------------------------------------------------------------------++binarySerialize :: forall a. IsTType a => Value a -> Builder+binarySerialize = case (ttype :: TType a) of+ TBinary -> serializeBinary+ TBool -> serializeBool+ TByte -> serializeByte+ TDouble -> serializeDouble+ TInt16 -> serializeInt16+ TInt32 -> serializeInt32+ TInt64 -> serializeInt64+ TStruct -> serializeStruct+ TList -> serializeList+ TMap -> serializeMap+ TSet -> serializeSet+{-# INLINE binarySerialize #-}++serializeBinary :: Value TBinary -> Builder+serializeBinary (VBinary x) = string x+{-# INLINE serializeBinary #-}++serializeBool :: Value TBool -> Builder+serializeBool (VBool x) = BB.int8 $ if x then 1 else 0+{-# INLINE serializeBool #-}++serializeByte :: Value TByte -> Builder+serializeByte (VByte x) = BB.int8 x+{-# INLINE serializeByte #-}++serializeDouble :: Value TDouble -> Builder+serializeDouble (VDouble x) = BB.doubleBE x+{-# INLINE serializeDouble #-}++serializeInt16 :: Value TInt16 -> Builder+serializeInt16 (VInt16 x) = BB.int16BE x+{-# INLINE serializeInt16 #-}++serializeInt32 :: Value TInt32 -> Builder+serializeInt32 (VInt32 x) = BB.int32BE x+{-# INLINE serializeInt32 #-}++serializeInt64 :: Value TInt64 -> Builder+serializeInt64 (VInt64 x) = BB.int64BE x+{-# INLINE serializeInt64 #-}++serializeList :: Value TList -> Builder+serializeList (VList xs) = serializeCollection ttype xs+{-# INLINE serializeList #-}++serializeSet :: Value TSet -> Builder+serializeSet (VSet xs) = serializeCollection ttype xs+{-# INLINE serializeSet #-}++serializeStruct :: Value TStruct -> Builder+serializeStruct (VStruct fields) =+ M.foldlWithKey'+ (\rest fid (SomeValue val) -> rest <> writeField fid ttype val)+ mempty fields+ <> BB.int8 0+ where+ writeField :: IsTType a => Int16 -> TType a -> Value a -> Builder+ writeField fieldId fieldType fieldValue =+ typeCode fieldType <> BB.int16BE fieldId <> binarySerialize fieldValue+ {-# INLINE writeField #-}+{-# INLINE serializeStruct #-}++serializeMap :: Value TMap -> Builder+serializeMap (VMap items) = serialize ttype ttype items+ where+ serialize+ :: (IsTType k, IsTType v)+ => TType k -> TType v -> FL.FoldList (MapItem k v) -> Builder+ serialize kt vt xs =+ typeCode kt <> typeCode vt <> BB.int32BE size <> body+ where+ (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs+ go (prev, !c) (MapItem k v) =+ ( prev <> binarySerialize k <> binarySerialize v+ , c + 1+ )+{-# INLINE serializeMap #-}++serializeCollection+ :: IsTType a+ => TType a -> FL.FoldList (Value a) -> Builder+serializeCollection vtype xs =+ let go (prev, !c) item = (prev <> binarySerialize item, c + 1)+ (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs+ in typeCode vtype <> BB.int32BE size <> body+{-# INLINE serializeCollection #-}++------------------------------------------------------------------------------+++messageCode :: MessageType -> Int8+messageCode Call = 1+messageCode Reply = 2+messageCode Exception = 3+messageCode Oneway = 4+{-# INLINE messageCode #-}+++fromMessageCode :: Int8 -> Maybe MessageType+fromMessageCode 1 = Just Call+fromMessageCode 2 = Just Reply+fromMessageCode 3 = Just Exception+fromMessageCode 4 = Just Oneway+fromMessageCode _ = Nothing+{-# INLINE fromMessageCode #-}+++-- | Map a TType to its type code.+toTypeCode :: TType a -> Int8+toTypeCode TBool = 2+toTypeCode TByte = 3+toTypeCode TDouble = 4+toTypeCode TInt16 = 6+toTypeCode TInt32 = 8+toTypeCode TInt64 = 10+toTypeCode TBinary = 11+toTypeCode TStruct = 12+toTypeCode TMap = 13+toTypeCode TSet = 14+toTypeCode TList = 15+{-# INLINE toTypeCode #-}+++-- | Map a type code to the corresponding TType.+fromTypeCode :: Int8 -> Maybe SomeTType+fromTypeCode 2 = Just $ SomeTType TBool+fromTypeCode 3 = Just $ SomeTType TByte+fromTypeCode 4 = Just $ SomeTType TDouble+fromTypeCode 6 = Just $ SomeTType TInt16+fromTypeCode 8 = Just $ SomeTType TInt32+fromTypeCode 10 = Just $ SomeTType TInt64+fromTypeCode 11 = Just $ SomeTType TBinary+fromTypeCode 12 = Just $ SomeTType TStruct+fromTypeCode 13 = Just $ SomeTType TMap+fromTypeCode 14 = Just $ SomeTType TSet+fromTypeCode 15 = Just $ SomeTType TList+fromTypeCode _ = Nothing+{-# INLINE fromTypeCode #-}++------------------------------------------------------------------------------+++string :: ByteString -> Builder+string b = BB.int32BE (fromIntegral $ B.length b) <> BB.byteString b+{-# INLINE string #-}++typeCode :: TType a -> Builder+typeCode = BB.int8 . toTypeCode+{-# INLINE typeCode #-}