packages feed

pinch (empty) → 0.1.0.0

raw patch · 33 files changed

+3999/−0 lines, 33 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, bytestring, containers, criterion, deepseq, hashable, hspec, hspec-discover, pinch, text, unordered-containers, vector

Files

+ CHANGES.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++-   Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Abhinav Gupta++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Abhinav Gupta nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Pinch.hs view
@@ -0,0 +1,525 @@+{-# 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(..)++    -- ** 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.ByteString.Lazy (toStrict)+import Data.Int             (Int32)+import Data.Text            (Text)++import qualified Data.ByteString.Builder as BB++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++builderToStrict :: BB.Builder -> ByteString+builderToStrict = toStrict . BB.toLazyByteString+{-# INLINE  builderToStrict #-}++-- TODO we know the size of the serialized payload. can probably pre-allocate+-- the byte string before filling it with the contents of the builder.++------------------------------------------------------------------------------++-- $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 = builderToStrict . snd . 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 >=> 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 = builderToStrict . snd . 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 = 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/Builder.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      :  Pinch.Internal.Builder+-- Copyright   :  (c) Abhinav Gupta 2015+-- License     :  BSD3+--+-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>+-- Stability   :  experimental+--+-- This module provides a wrapper around @Data.ByteString.Builder@ that keeps+-- track of the final size of the generated ByteString.+module Pinch.Internal.Builder+    ( Builder+    , Build+    , run++    , int8+    , int16+    , int32+    , int64+    , double+    , byteString+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Data.ByteString (ByteString)+import Data.Int+import Data.Monoid+import Prelude         hiding (length)++import qualified Data.ByteString         as B+import qualified Data.ByteString.Builder as BB++-- | Alias for a build that produces no results.+type Build = Builder ()++-- We're using big endian byte order for now. We can add little endian later+-- if needed.++-- | Used for building a long chain of ByteStrings.+data Builder a = B !a {-# UNPACK #-} !Int64 !BB.Builder+    -- TODO CPS?++instance Functor Builder where+    fmap f (B a l b) = B (f a) l b++instance Applicative Builder where+    pure a = B a 0 mempty+    B f l0 b0 <*> B a l1 b1 = B (f a) (l0 + l1) (b0 <> b1)++instance Monad Builder where+    (>>) = (*>)+    return = pure+    B a l0 b0 >>= k =+        let B b l1 b1 = k a+        in  B b (l0 + l1) (b0 <> b1)++-- | Returns the ByteString Builder for this build and its length.+run :: Build -> (Int64, BB.Builder)+run (B () l b) = (l, b)+++-- | Writes a byte.+int8 :: Int8 -> Build+int8 = B () 1 . BB.int8+++-- | Writes a 16-bit integer.+int16 :: Int16 -> Build+int16 = B () 2 . BB.int16BE+++-- | Writes a 32-bit integer.+int32 :: Int32 -> Build+int32 = B () 4 . BB.int32BE+++-- | Writes a 64-bit integer.+int64 :: Int64 -> Build+int64 = B () 8 . BB.int64BE+++-- | Writes a 64-bit double.+double :: Double -> Build+double = B () 8 . BB.doubleBE+++-- | Writes an arbitrary ByteString.+byteString :: ByteString -> Build+byteString bs = B () (fromIntegral $ B.length bs) (BB.byteString bs)
+ Pinch/Internal/Generic.hs view
@@ -0,0 +1,239 @@+{-# 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 OVERLAPPABLE+#else+#define OVERLAPPABLE {-# 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 OVERLAPPABLE 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 = case gUnpinch v of+        Left msg -> Left $ "Failed to read '" ++ name ++ "': " ++ msg+        Right a -> Right $ M1 a+      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 OVERLAPPABLE (Pinchable a, KnownNat n)+  => GPinchable (K1 i (Field n a)) where+    type GTag (K1 i (Field n a)) = TStruct+    gPinch (K1 (Field a)) = struct [n .= a]+      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 = Left $ "Couldn't match enum value " ++ show i+      where+        val = fromIntegral $ natVal (Proxy :: Proxy n)+    gUnpinch x = Left $ "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 = Right $ K1 Void+    gUnpinch x = Left $+        "Failed to read response. Expected void, got: " ++ show x
+ 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
+ Pinch/Internal/Parser.hs view
@@ -0,0 +1,168 @@+{-# 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        (shiftL, (.|.))+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+++-- | 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+    fmap f (Parser g) = Parser+        $ \b0 kFail kSucc -> g b0 kFail+        $ \b1 a -> kSucc b1 (f a)+++instance Applicative Parser where+    pure a = Parser $ \b _ kSucc -> kSucc b a++    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+    return = pure+    (>>) = (*>)++    fail msg = Parser $ \_ kFail _ -> kFail msg++    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 (b `BU.unsafeIndex` 0) `shiftL` 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 (b `BU.unsafeIndex` 0) `shiftL` 24) .|.+        (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 16) .|.+        (fromIntegral (b `BU.unsafeIndex` 2) `shiftL`  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 (b `BU.unsafeIndex` 0) `shiftL` 56) .|.+        (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 48) .|.+        (fromIntegral (b `BU.unsafeIndex` 2) `shiftL` 40) .|.+        (fromIntegral (b `BU.unsafeIndex` 3) `shiftL` 32) .|.+        (fromIntegral (b `BU.unsafeIndex` 4) `shiftL` 24) .|.+        (fromIntegral (b `BU.unsafeIndex` 5) `shiftL` 16) .|.+        (fromIntegral (b `BU.unsafeIndex` 6) `shiftL`  8) .|.+         fromIntegral (b `BU.unsafeIndex` 7)+{-# INLINE int64 #-}+++-- | Produces a 64-bit floating point number and advances the parser.+double :: Parser Double+double = do+    i <- int64+    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 view
@@ -0,0 +1,320 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE KindSignatures       #-}+{-# 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+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Data.ByteString     (ByteString)+import Data.Hashable       (Hashable)+import Data.HashMap.Strict (HashMap)+import Data.Int            (Int16, Int32, Int64, Int8)+import Data.Text           (Text)+import Data.Typeable       ((:~:) (..), eqT)+import Data.Vector         (Vector)+import GHC.Generics        (Generic, Rep)++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.Vector         as V+import qualified GHC.Generics        as G++import Pinch.Internal.TType+import Pinch.Internal.Value++-- | 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)) -> Either String 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) -> Either String (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) -> Either String 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)) -> Either String 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 . foldr go HM.empty+  where+    go (_, Nothing) m = m+    go (k, Just v) m = 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 -> Either String a+(VStruct items) .: fieldId = do+    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 '" ++ showSomeValueTType someValue ++ "'")+          $ castValue someValue+    unpinch value+  where+    showSomeValueTType (SomeValue v) = show (valueTType v)+    note msg m = case m of+        Nothing -> Left msg+        Just v -> Right 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 -> Either String (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 >>= castValue++------------------------------------------------------------------------------++-- | Helper to 'unpinch' values by matching TTypes.+checkedUnpinch+    :: forall a b. (Pinchable a, IsTType b)+    => Value b -> Either String a+checkedUnpinch = case eqT of+    Nothing -> const . Left $+        "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+    :: forall k v kval vval m.+        ( Pinchable k+        , Pinchable v+        , kval ~ Value (Tag k)+        , vval ~ Value (Tag v)+        )+    => ((k -> v -> HashMap kval vval -> HashMap kval vval)+           -> HashMap kval vval -> m -> HashMap kval vval)+          -- ^ @foldrWithKey@+    -> m  -- ^ map that implements @foldrWithKey@+    -> Value TMap+pinchMap folder = VMap . folder go HM.empty+  where+    go k v = HM.insert (pinch k) (pinch v)+++instance IsTType a => Pinchable (Value a) where+    type Tag (Value a) = a+    pinch = id+    unpinch = Right++instance Pinchable ByteString where+    type Tag ByteString = TBinary+    pinch = VBinary+    unpinch (VBinary b) = Right b+    unpinch x = Left $ "Failed to read binary. Got " ++ show x++instance Pinchable Text where+    type Tag Text = TBinary+    pinch = VBinary . TE.encodeUtf8+    unpinch (VBinary b) = Right . TE.decodeUtf8 $ b+    unpinch x = Left $ "Failed to read string. Got " ++ show x++instance Pinchable Bool where+    type Tag Bool = TBool+    pinch = VBool+    unpinch (VBool x) = Right x+    unpinch x = Left $ "Failed to read boolean. Got " ++ show x++instance Pinchable Int8 where+    type Tag Int8 = TByte+    pinch = VByte+    unpinch (VByte x) = Right x+    unpinch x = Left $ "Failed to read byte. Got " ++ show x++instance Pinchable Double where+    type Tag Double = TDouble+    pinch = VDouble+    unpinch (VDouble x) = Right x+    unpinch x = Left $ "Failed to read double. Got " ++ show x++instance Pinchable Int16 where+    type Tag Int16 = TInt16+    pinch = VInt16+    unpinch (VInt16 x) = Right x+    unpinch x = Left $ "Failed to read i16. Got " ++ show x++instance Pinchable Int32 where+    type Tag Int32 = TInt32+    pinch = VInt32+    unpinch (VInt32 x) = Right x+    unpinch x = Left $ "Failed to read i32. Got " ++ show x++instance Pinchable Int64 where+    type Tag Int64 = TInt64+    pinch = VInt64+    unpinch (VInt64 x) = Right x+    unpinch x = Left $ "Failed to read i64. Got " ++ show x++instance Pinchable a => Pinchable (Vector a) where+    type Tag (Vector a) = TList+    pinch = VList . V.map pinch+    unpinch (VList xs) = V.mapM checkedUnpinch xs+    unpinch x = Left $ "Failed to read list. Got " ++ show x++instance Pinchable a => Pinchable [a] where+    type Tag [a] = TList+    pinch = VList . V.fromList . map pinch+    unpinch (VList xs) = mapM checkedUnpinch $ V.toList xs+    unpinch x = Left $ "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.foldrWithKey++    unpinch (VMap xs) =+        fmap HM.fromList . mapM go $ HM.toList xs+      where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v+    unpinch x = Left $ "Failed to read map. Got " ++ show x++instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where+    type Tag (M.Map k v) = TMap+    pinch = pinchMap M.foldrWithKey++    unpinch (VMap xs) =+        fmap M.fromList . mapM go $ HM.toList xs+      where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v+    unpinch x = Left $ "Failed to read map. Got " ++ show x++instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where+    type Tag (HS.HashSet a) = TSet+    pinch = VSet . HS.map pinch+    unpinch (VSet xs) =+        fmap HS.fromList . mapM checkedUnpinch $ HS.toList xs+    unpinch x = Left $ "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 . S.foldr (HS.insert . pinch) HS.empty+    unpinch (VSet xs) =+        fmap S.fromList . mapM checkedUnpinch $ HS.toList xs+    unpinch x = Left $ "Failed to read set. Got " ++ show x
+ Pinch/Internal/TType.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE StandaloneDeriving #-}+-- |+-- 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(..)++    -- * 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
+ Pinch/Internal/Value.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# 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(..)+    , SomeValue(..)+    , castValue+    , valueTType+    ) where++import Control.DeepSeq     (NFData (..))+import Data.ByteString     (ByteString)+import Data.Hashable       (Hashable (..))+import Data.HashMap.Strict (HashMap)+import Data.HashSet        (HashSet)+import Data.Int            (Int16, Int32, Int64, Int8)+import Data.Typeable       ((:~:) (..), Typeable, cast, eqT)+import Data.Vector         (Vector)++import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import qualified Data.Vector         as V++import Pinch.Internal.TType+++-- | @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)+          => !(HashMap (Value k) (Value v)) -> Value TMap+    VSet  :: forall a. IsTType a => !(HashSet (Value a)) -> Value TSet+    VList :: forall a. IsTType a => !(Vector (Value a)) -> Value TList+  deriving Typeable++deriving instance Show (Value a)++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++    VMap  as == VMap  bs = areEqual as bs+    VSet  as == VSet  bs = areEqual as bs+    VList as == VList bs = areEqual as bs++    _ == _ = False++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 'SomeValue' into a 'Value'.+castValue :: Typeable a => SomeValue -> Maybe (Value a)+castValue (SomeValue v) = cast v+++-- | Get the 'TType' of a 'Value'.+valueTType :: IsTType a => Value a -> TType a+valueTType _ = ttype++-- | Helper to compare two types that are not known to be equal at compile+-- time.+areEqual+    :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool+areEqual x y = case eqT of+    Nothing -> False+    Just (Refl :: a :~: b) -> x == y+++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 xs ->+        V.foldr' (flip hashWithSalt) (s `hashWithSalt` (7 :: Int)) xs+      VMap xs ->+        M.foldrWithKey+          (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v)+          (s `hashWithSalt` (8 :: Int))+          xs+      VSet xs ->+        S.foldr (flip hashWithSalt) (s `hashWithSalt` (9 :: Int)) xs++      VStruct fields ->+        M.foldrWithKey (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v)+                       (s `hashWithSalt` (10 :: Int))+                       fields+++instance Hashable SomeValue where+    hashWithSalt s (SomeValue v) = hashWithSalt s v
+ Pinch/Protocol.hs view
@@ -0,0 +1,42 @@+{-# 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 Data.ByteString.Builder (Builder)+import Data.Int                (Int64)++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 -> (Int64, Builder)+    -- ^ Serializes a 'Value' into a ByteString builder.+    --+    -- Returns a @Builder@ and the total length of the serialized content.+    , serializeMessage :: Message -> (Int64, 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 view
@@ -0,0 +1,305 @@+{-# 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.HashSet        (HashSet)+import Data.Int            (Int16, Int8)+import Data.Vector         (Vector)++import qualified Data.ByteString     as B+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import qualified Data.Text.Encoding  as TE+import qualified Data.Vector         as V++import Pinch.Internal.Builder (Build)+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.Parser  as P+++-- | Provides an implementation of the Thrift Binary Protocol.+binaryProtocol :: Protocol+binaryProtocol = Protocol+    { serializeValue     = BB.run . binarySerialize+    , deserializeValue   = binaryDeserialize ttype+    , serializeMessage   = BB.run . binarySerializeMessage+    , deserializeMessage = binaryDeserializeMessage+    }++------------------------------------------------------------------------------++binarySerializeMessage :: Message -> Build+binarySerializeMessage msg = do+    binarySerialize . VBinary . TE.encodeUtf8 $ messageName msg+    BB.int8  $ messageCode (messageType msg)+    BB.int32 $ 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+        pairs <- replicateM (fromIntegral count) $+            (,) <$> binaryParser ktype+                <*> binaryParser vtype+        return $ VMap (M.fromList pairs)+++parseSet :: Parser (Value TSet)+parseSet = do+    vtype' <- parseTType+    count <- P.int32++    case vtype' of+      SomeTType vtype -> do+          items <- replicateM (fromIntegral count) (binaryParser vtype)+          return $ VSet (S.fromList items)+++parseList :: Parser (Value TList)+parseList = do+    vtype' <- parseTType+    count <- P.int32++    case vtype' of+      SomeTType vtype ->+        VList <$> V.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 :: Value a -> Build+binarySerialize v0 = case v0 of+  VBinary  x -> do+    BB.int32 . fromIntegral . B.length $ x+    BB.byteString x+  VBool    x -> BB.int8 $ if x then 1 else 0+  VByte    x -> BB.int8   x+  VDouble  x -> BB.double x+  VInt16   x -> BB.int16  x+  VInt32   x -> BB.int32  x+  VInt64   x -> BB.int64  x+  VStruct xs -> serializeStruct xs+  VList   xs -> serializeList ttype       xs+  VMap    xs -> serializeMap  ttype ttype xs+  VSet    xs -> serializeSet  ttype       xs+++serializeStruct :: HashMap Int16 SomeValue -> Build+serializeStruct fields = do+    forM_ (M.toList fields) $ \(fieldId, SomeValue fieldValue) ->+        writeField fieldId ttype fieldValue+    BB.int8 0+  where+    writeField :: Int16 -> TType a -> Value a -> Build+    writeField fieldId fieldType fieldValue = do+        BB.int8 (toTypeCode fieldType)+        BB.int16 fieldId+        binarySerialize fieldValue+++serializeList :: TType a -> Vector (Value a) -> Build+serializeList vtype xs = do+    BB.int8  $ toTypeCode vtype+    BB.int32 $ fromIntegral (V.length xs)+    mapM_ binarySerialize (V.toList xs)+++serializeMap :: TType k -> TType v -> HashMap (Value k) (Value v) -> Build+serializeMap kt vt xs = do+    BB.int8  $ toTypeCode kt+    BB.int8  $ toTypeCode vt+    BB.int32 $ fromIntegral (M.size xs)+    forM_ (M.toList xs) $ \(k, v) -> do+        binarySerialize k+        binarySerialize v+++serializeSet :: TType a -> HashSet (Value a) -> Build+serializeSet vtype xs = do+    BB.int8  $ toTypeCode vtype+    BB.int32 $ fromIntegral (S.size xs)+    mapM_ binarySerialize (S.toList xs)+++------------------------------------------------------------------------------+++messageCode :: MessageType -> Int8+messageCode Call      = 1+messageCode Reply     = 2+messageCode Exception = 3+messageCode Oneway    = 4+++fromMessageCode :: Int8 -> Maybe MessageType+fromMessageCode 1 = Just Call+fromMessageCode 2 = Just Reply+fromMessageCode 3 = Just Exception+fromMessageCode 4 = Just Oneway+fromMessageCode _ = Nothing+++-- | 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+++-- | 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
+ README.md view
@@ -0,0 +1,10 @@+`pinch` aims to provide an alternative implementation of Apache Thrift for+Haskell. The `pinch` library itself acts only as a serialization library. Types+specify their Thrift encoding by defining instances of the `Pinchable`+typeclass, which may be done by hand or automatically with the use of Generics.+Check the documentation and examples for more information.++Haddock documentation for this package is avilable on [Hackage] and [here].++  [Hackage]: http://hackage.haskell.org/package/pinch+  [here]: http://abhinavg.net/pinch/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,104 @@+{-# 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
+ examples/keyvalue/Client.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+module Main (main) where++import Control.Monad+import Control.Monad.Catch  (Exception, throwM)+import Data.ByteString      (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.Char            (isSpace)+import Data.Function        (fix)+import Data.Maybe+import Data.Text            (Text)+import Data.Text.Encoding   (encodeUtf8)+import Data.Typeable        (Typeable)++import qualified Data.Text           as T+import qualified Data.Text.IO        as TIO+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types  as HTTP+import qualified Pinch               as P++import Types+++data ClientError+    = HTTPError HTTP.Status ByteString+    | ThriftProtocolError String+  deriving (Show, Eq, Typeable)++instance Exception ClientError+++keyValueClient :: String -> HTTP.Manager -> KeyValue IO+keyValueClient url manager = KeyValue+    { getValue = mkRequest "getValue"+    , setValue = mkRequest "setValue"+    }+  where+    baseRequest = fromMaybe (error "Invalid URL") (HTTP.parseUrl url)++    encode = P.encodeMessage P.binaryProtocol+    decode = P.decodeMessage P.binaryProtocol++    mkRequest :: forall req res.+        ( P.Pinchable req, P.Tag req ~ P.TStruct+        , P.Pinchable res, P.Tag res ~ P.TStruct+        ) => Text -> req -> IO res+    mkRequest name call = do+        res <- HTTP.httpLbs req manager++        let status = HTTP.responseStatus res+            body = toStrict (HTTP.responseBody res)++        unless (HTTP.statusIsSuccessful status) $+            throwM (HTTPError status body)++        case decode body >>= P.getMessageBody of+            Left err -> throwM (ThriftProtocolError err)+            Right reply -> return reply+      where+        message = P.mkMessage name P.Call 0 call+        req = baseRequest+            { HTTP.method = "POST"+            , HTTP.requestBody = HTTP.RequestBodyBS $ encode message+            }+++main :: IO ()+main = do+    client <- keyValueClient "http://localhost:8080"+          <$> HTTP.newManager HTTP.defaultManagerSettings++    fix $ \loop -> do+        line <- TIO.getLine+        case T.split isSpace line of+            ["quit"] -> return ()++            ["get", key] -> do+                res <- getValue client (GetValueRequest (P.putField key))+                case res of+                    GetValueSuccess value  -> print value+                    GetValueDoesNotExist _ -> putStrLn "No matching value."+                loop++            ["set", key, value] -> do+                let v = ValueBin (P.putField (encodeUtf8 value))+                _ <- setValue client $+                     SetValueRequest (P.putField key) (P.putField v)+                loop++            _ -> putStrLn "Invalid command" >> loop
+ examples/keyvalue/Server.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+module Main (main) where++import Data.ByteString.Lazy       (fromStrict, toStrict)+import Data.ByteString.Lazy.Char8 (pack)+import Data.IORef                 (IORef)+import Data.Map.Strict            (Map)+import Data.Text                  (Text)+import Network.Wai.Handler.Warp   (run)++import qualified Data.IORef         as IORef+import qualified Data.Map.Strict    as Map+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai        as HTTP+import qualified Pinch              as P++import Types hiding (KeyValue (..))++type ValueStore = IORef (Map Text Value)++newValueStore :: IO ValueStore+newValueStore = IORef.newIORef Map.empty++getValue :: ValueStore -> GetValueRequest -> IO GetValueResponse+getValue store req = do+    m <- IORef.readIORef store+    return $! case key `Map.lookup` m of+        Nothing ->+            GetValueDoesNotExist . P.putField $+            KeyDoesNotExist (P.putField Nothing)+        Just value ->+            GetValueSuccess (P.putField value)+  where+    GetValueRequest{getValueKey = P.Field key} = req++setValue :: ValueStore -> SetValueRequest -> IO SetValueResponse+setValue store req = do+    IORef.atomicModifyIORef' store (\m -> (Map.insert key value m, ()))+    return $ SetValueSuccess P.Void+  where+    SetValueRequest+        { setValueKey = P.Field key+        , setValueValue = P.Field value+        } = req++app :: ValueStore -> HTTP.Application+app store request respond = do+    requestBody <- toStrict <$> HTTP.strictRequestBody request+    either handleError handleMessage $ decode requestBody+  where+    encode = P.encodeMessage P.binaryProtocol+    decode = P.decodeMessage P.binaryProtocol++    respondSuccess = respond . HTTP.responseLBS HTTP.status200 [] . fromStrict+    handleError err = respond $ HTTP.responseLBS HTTP.status500 [] (pack err)++    handle+        :: forall req res.+            ( P.Pinchable req, P.Tag req ~ P.TStruct+            , P.Pinchable res, P.Tag res ~ P.TStruct+            )+        => (ValueStore -> req -> IO res) -> P.Message+        -> IO HTTP.ResponseReceived+    handle f msg = case P.getMessageBody msg of+        Left err -> handleError err+        Right (req :: req) -> do+            res <- f store req+            respondSuccess . encode $+                P.mkMessage messageName P.Reply messageId res+      where+        messageName = P.messageName msg+        messageId = P.messageId msg++    handleMessage m = case P.messageName m of+        "getValue" -> handle getValue m+        "setValue" -> handle setValue m+        name -> handleError $ "Unknown method: " ++ show name+        -- TODO use TApplicationException format for this++main :: IO ()+main = newValueStore >>= \store -> run 8080 (app store)
+ examples/keyvalue/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/keyvalue/Types.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE DeriveGeneric #-}+module Types+    ( Value(..)+    , KeyDoesNotExist(..)++    , SetValueRequest(..)+    , SetValueResponse(..)++    , GetValueRequest(..)+    , GetValueResponse(..)++    , KeyValue(..)+    ) where++import Data.ByteString (ByteString)+import Data.Set        (Set)+import Data.Text       (Text)+import GHC.Generics    (Generic)++import qualified Pinch as P++data Value+    = ValueBin (P.Field 1 ByteString)+    | ValueBinSet (P.Field 2 (Set ByteString))+    deriving (Show, Ord, Eq, Generic)++instance P.Pinchable Value+++data KeyDoesNotExist = KeyDoesNotExist (P.Field 1 (Maybe Text))+    deriving (Show, Ord, Eq, Generic)++instance P.Pinchable KeyDoesNotExist+++data SetValueRequest = SetValueRequest+    { setValueKey   :: P.Field 1 Text+    , setValueValue :: P.Field 2 Value+    } deriving (Show, Ord, Eq, Generic)++instance P.Pinchable SetValueRequest+++data SetValueResponse = SetValueSuccess P.Void+    deriving (Show, Ord, Eq, Generic)++instance P.Pinchable SetValueResponse+++data GetValueRequest = GetValueRequest+    { getValueKey :: P.Field 1 Text+    } deriving (Show, Ord, Eq, Generic)++instance P.Pinchable GetValueRequest+++data GetValueResponse+    = GetValueSuccess (P.Field 0 Value)+    | GetValueDoesNotExist (P.Field 1 KeyDoesNotExist)+    deriving (Show, Ord, Eq, Generic)++instance P.Pinchable GetValueResponse++data KeyValue m = KeyValue+    { getValue :: GetValueRequest -> m GetValueResponse+    , setValue :: SetValueRequest -> m SetValueResponse+    }
+ examples/keyvalue/keyvalue.cabal view
@@ -0,0 +1,36 @@+name          : keyvalue+version       : 0.1.0.0+author        : Abhinav Gupta+maintainer    : mail@abhinavg.net+build-type    : Simple+cabal-version : >=1.10++executable keyvalue-server+  main-is             : Server.hs+  other-modules       : Types+  ghc-options         : -Wall -threaded+  build-depends       : base+                      , bytestring+                      , containers+                      , http-types  >= 0.8 && < 0.9+                      , text+                      , wai  >= 3.0 && < 4.0+                      , warp >= 3.0 && < 4.0++                      , pinch+  default-language    : Haskell2010++executable keyvalue-client+  main-is             : Client.hs+  other-modules       : Types+  ghc-options         : -Wall -threaded+  build-depends       : base+                      , bytestring+                      , containers+                      , exceptions+                      , http-client >= 0.4 && < 0.5+                      , http-types  >= 0.8 && < 0.9+                      , text++                      , pinch+  default-language    : Haskell2010
+ examples/keyvalue/keyvalue.thrift view
@@ -0,0 +1,15 @@+exception KeyDoesNotExist {+    1: optional string message+}++union Value {+    1: binary bin+    2: set<binary> binSet+}++service KeyValue {+    void setValue(1: string key, 2: Value value)++    Value getValue(1: string key)+        throws (1: KeyDoesNotExist doesNotExist)+}
+ pinch.cabal view
@@ -0,0 +1,107 @@+name:                pinch+version:             0.1.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.+extra-source-files:+    README.md+    CHANGES.md+    examples/keyvalue/*.hs+    examples/keyvalue/*.cabal+    examples/keyvalue/*.thrift+++library+  exposed-modules  : Pinch.Internal.Generic+                   , Pinch.Internal.Builder+                   , Pinch.Internal.Message+                   , Pinch.Internal.Parser+                   , Pinch.Internal.Pinchable+                   , Pinch.Internal.TType+                   , Pinch.Internal.Value+                   , Pinch.Protocol+                   , Pinch.Protocol.Binary+                   , Pinch+  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+                   , hashable             >= 1.2  && < 1.3+                   , text                 >= 1.2  && < 1.3+                   , unordered-containers >= 0.2  && < 0.3+                   , vector               >= 0.10 && < 0.11+  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.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
+ tests/Pinch/Arbitrary.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Pinch.Arbitrary+    ( SomeByteString(..)+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Data.ByteString    (ByteString)+import Data.Text          (Text)+import Test.QuickCheck++import qualified Data.ByteString     as B+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+import qualified Data.Text           as Tx+import qualified Data.Vector         as V++import qualified Pinch.Internal.Message as TM+import qualified Pinch.Internal.TType   as T+import qualified Pinch.Internal.Value   as V++#if !MIN_VERSION_QuickCheck(2, 8, 0)+scale :: (Int -> Int) -> Gen a -> Gen a+scale f g = sized (\n -> resize (f n) g)+#endif++halfSize :: Gen a -> Gen a+halfSize = scale (\n -> truncate (fromIntegral n / 2 :: Double))++newtype SomeByteString = SomeByteString+    { getSomeByteString :: ByteString }+  deriving (Show, Eq)++instance Arbitrary SomeByteString where+    arbitrary = SomeByteString . B.pack <$> arbitrary++    shrink (SomeByteString bs)+        | B.null bs = []+        | otherwise =+            SomeByteString . B.pack <$> shrink (B.unpack bs)++newtype SomeText = SomeText { getSomeText :: Text }++instance Arbitrary SomeText where+    arbitrary = SomeText . Tx.pack <$> arbitrary+    shrink = map (SomeText . Tx.pack) . shrink . Tx.unpack . getSomeText+++instance Arbitrary T.SomeTType where+    arbitrary = elements+        [ T.SomeTType T.TBool+        , T.SomeTType T.TByte+        , T.SomeTType T.TDouble+        , T.SomeTType T.TInt16+        , T.SomeTType T.TInt32+        , T.SomeTType T.TInt64+        , T.SomeTType T.TBinary+        , T.SomeTType T.TStruct+        , T.SomeTType T.TMap+        , T.SomeTType T.TSet+        , T.SomeTType T.TList+        ]+    shrink _ = []++instance Arbitrary V.SomeValue where+    arbitrary = arbitrary >>= \(T.SomeTType t) -> genValue t+      where+        genValue+            :: forall a. T.IsTType a+            => T.TType a -> Gen V.SomeValue+        genValue _ = V.SomeValue <$> (arbitrary :: Gen (V.Value a))++    shrink (V.SomeValue v) = V.SomeValue <$> shrink v+++instance T.IsTType a => Arbitrary (V.Value a) where+    arbitrary = case T.ttype :: T.TType a of+        T.TBool -> V.VBool <$> arbitrary+        T.TByte -> V.VByte <$> arbitrary+        T.TDouble -> V.VDouble <$> arbitrary+        T.TInt16 -> V.VInt16 <$> arbitrary+        T.TInt32 -> V.VInt32 <$> arbitrary+        T.TInt64 -> V.VInt64 <$> arbitrary+        T.TBinary -> V.VBinary . getSomeByteString <$> arbitrary+        T.TStruct -> genStruct+        T.TMap -> do+            ktype <- arbitrary+            vtype <- arbitrary+            case (ktype, vtype) of+                (T.SomeTType kt, T.SomeTType vt) ->+                    V.VMap <$> genMap kt vt+        T.TSet -> arbitrary >>= \(T.SomeTType t) -> V.VSet <$> genSet t+        T.TList -> arbitrary >>= \(T.SomeTType t) -> V.VList <$> genVec t+      where+        genStruct = halfSize $ V.VStruct . M.fromList <$> listOf genField+          where+            genField = (,) <$> (getPositive <$> arbitrary)+                           <*> arbitrary++        genMap :: (T.IsTType k, T.IsTType v)+               => T.TType k -> T.TType v+               -> Gen (M.HashMap (V.Value k) (V.Value v))+        genMap _ _ = M.fromList <$> halfSize arbitrary++        genSet :: T.IsTType x => T.TType x -> Gen (S.HashSet (V.Value x))+        genSet _ = S.fromList <$> halfSize arbitrary++        genVec :: T.IsTType x => T.TType x -> Gen (V.Vector (V.Value x))+        genVec _ = V.fromList <$> halfSize arbitrary++    shrink = case T.ttype :: T.TType a of+        T.TByte -> \(V.VByte x) -> V.VByte <$> shrink x+        T.TDouble -> \(V.VDouble x) -> V.VDouble <$> shrink x+        T.TInt16 -> \(V.VInt16 x) -> V.VInt16 <$> shrink x+        T.TInt32 -> \(V.VInt32 x) -> V.VInt32 <$> shrink x+        T.TInt64 -> \(V.VInt64 x) -> V.VInt64 <$> shrink x+        T.TBinary -> shrinkBinary+        T.TStruct ->+            \(V.VStruct xs) -> V.VStruct . M.fromList <$> shrink (M.toList xs)+        T.TMap ->+            \(V.VMap xs) -> V.VMap . M.fromList <$> shrink (M.toList xs)+        T.TSet ->+            \(V.VSet xs) -> V.VSet . S.fromList <$> shrink (S.toList xs)+        T.TList ->+            \(V.VList xs) -> V.VList . V.fromList <$> shrink (V.toList xs)+        _ -> const []+      where+        shrinkBinary :: V.Value T.TBinary -> [V.Value T.TBinary]+        shrinkBinary (V.VBinary bs)+            | B.null bs = []+            | otherwise = V.VBinary . B.pack <$> shrink (B.unpack bs)+++instance Arbitrary TM.MessageType where+    arbitrary = elements+        [ TM.Call+        , TM.Reply+        , TM.Exception+        , TM.Oneway+        ]+    shrink _ = []+++instance Arbitrary TM.Message where+    arbitrary =+        TM.Message+            <$> (getSomeText <$> arbitrary)+            <*> arbitrary+            <*> arbitrary+            <*> arbitrary++    shrink (TM.Message name  typ  mid  body) =+        [   TM.Message name' typ' mid' body'+        | (SomeText name', typ', mid', body') <-+            shrink ((SomeText name), typ, mid, body)+        ]
+ tests/Pinch/Expectations.hs view
@@ -0,0 +1,17 @@+module Pinch.Expectations+    ( leftShouldContain+    , leftShouldContainAll+    ) where+++import Test.Hspec++-- | Expectation+leftShouldContain :: Show a => Either String a -> String -> Expectation+leftShouldContain (Right a) _ =+    expectationFailure $ "Expected failure but got: " ++ show a+leftShouldContain (Left msg) x = msg `shouldContain` x+infix 1 `leftShouldContain`++leftShouldContainAll :: Show a => Either String a -> [String] -> Expectation+leftShouldContainAll e = mapM_ (leftShouldContain e)
+ tests/Pinch/Internal/BuilderSpec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE NegativeLiterals  #-}+{-# LANGUAGE OverloadedStrings #-}+module Pinch.Internal.BuilderSpec (spec) where++import Control.Arrow           (second)+import Data.ByteString         (ByteString)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy    (toStrict)+import Data.Int                (Int64)+import Data.Word               (Word8)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import qualified Data.ByteString as B++import Pinch.Arbitrary+import Pinch.Internal.Builder (Build)++import qualified Pinch.Internal.Builder as BB++run :: Build -> (Int64, ByteString)+run = second (toStrict . toLazyByteString) . BB.run+++encodeCases+    :: (a -> Build) -> [([Word8], a)] -> Expectation+encodeCases encode = mapM_ . uncurry $ \bytes a -> do+    let (size, encoded) = run (encode a)+        expected = B.pack bytes+    encoded `shouldBe` expected+    fromIntegral size `shouldBe` B.length expected+++spec :: Spec+spec = describe "Builder" $ do++    it "can encode 8-bit integers" $+        encodeCases BB.int8+            [ ([0x01], 1)+            , ([0x05], 5)+            , ([0x7f], 127)+            , ([0xff], -1)+            , ([0x80], -128)+            ]++    it "can encode 16-bit integers" $+        encodeCases BB.int16+            [ ([0x00, 0x01], 1)+            , ([0x00, 0xff], 255)+            , ([0x01, 0x00], 256)+            , ([0x01, 0x01], 257)+            , ([0x7f, 0xff], 32767)+            , ([0xff, 0xff], -1)+            , ([0xff, 0xfe], -2)+            , ([0xff, 0x00], -256)+            , ([0xff, 0x01], -255)+            , ([0x80, 0x00], -32768)+            ]++    it "can encode 32-bit integers" $+        encodeCases BB.int32+            [ ([0x00, 0x00, 0x00, 0x01], 1)+            , ([0x00, 0x00, 0x00, 0xff], 255)+            , ([0x00, 0x00, 0xff, 0xff], 65535)+            , ([0x00, 0xff, 0xff, 0xff], 16777215)+            , ([0x7f, 0xff, 0xff, 0xff], 2147483647)+            , ([0xff, 0xff, 0xff, 0xff], -1)+            , ([0xff, 0xff, 0xff, 0x00], -256)+            , ([0xff, 0xff, 0x00, 0x00], -65536)+            , ([0xff, 0x00, 0x00, 0x00], -16777216)+            , ([0x80, 0x00, 0x00, 0x00], -2147483648)+            ]++    it "can encode 64-bit integers" $+        encodeCases BB.int64+            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1)+            , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295)+            , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775)+            , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 281474976710655)+            , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 72057594037927935)+            , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 9223372036854775807)+            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1)+            , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], -4294967296)+            , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], -1099511627776)+            , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -281474976710656)+            , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -72057594037927936)+            , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808)+            ]++    it "can encode doubles" $+        encodeCases BB.double+            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0)+            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0)+            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001)+            , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], 1.1)+            , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], -1.1)+            , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], 3.141592653589793)+            , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001)+            ]++    prop "can encode bytestrings" $ \(SomeByteString bs) ->+        run (BB.byteString bs) === (fromIntegral $ B.length bs, bs)++    it "can join multiple operations using (>>)" $+        encodeCases (\(a, b) -> BB.int16 a >> BB.byteString b)+            [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64]+              , (4660, "abcd")+              )+            , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f]+              , (0, "hello")+              )+            ]++    it "can join multiple operations using (>>=)" $+        encodeCases (\(a, b) -> BB.int16 a >>= \() -> BB.byteString b)+            [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64]+              , (4660, "abcd")+              )+            , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f]+              , (0, "hello")+              )+            ]
+ tests/Pinch/Internal/GenericSpec.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+module Pinch.Internal.GenericSpec (spec) where++import Data.ByteString       (ByteString)+import Data.Int              (Int32, Int8)+import Data.Set              (Set)+import Data.Text             (Text)+import GHC.Generics          (Generic)+import GHC.TypeLits          ()+import Test.Hspec+import Test.Hspec.QuickCheck++import qualified Data.Set as S++import Pinch.Expectations+import Pinch.Internal.Util++import qualified Pinch.Internal.Generic   as G+import qualified Pinch.Internal.Pinchable as P+import qualified Pinch.Internal.TType     as T+import qualified Pinch.Internal.Value     as V+++data AnEnum+    = EnumA (G.Enumeration 1)+    | EnumB (G.Enumeration 2)+    | EnumC (G.Enumeration 3)+  deriving (Show, Ord, Eq, Generic)++instance P.Pinchable AnEnum+++enumSpec :: Spec+enumSpec = describe "Enum" $ do++    it "can pinch and unpinch" $ do+        P.pinch (EnumA G.enum) `shouldBe` vi32 1+        P.pinch (EnumB G.enum) `shouldBe` vi32 2+        P.pinch (EnumC G.enum) `shouldBe` vi32 3++        P.unpinch (vi32 1) `shouldBe` Right (EnumA G.enum)+        P.unpinch (vi32 2) `shouldBe` Right (EnumB G.enum)+        P.unpinch (vi32 3) `shouldBe` Right (EnumC G.enum)++    it "reject invalid values" $+        (P.unpinch :: V.Value T.TInt32 -> Either String AnEnum)+          (vi32 4) `leftShouldContain` "Couldn't match enum value 4"++data AUnion+    = UnionDouble (G.Field 1 Double)+    | UnionByte   (G.Field 2 Int8)+    | UnionSet    (G.Field 5 (Set AnEnum))+  deriving (Show, Ord, Eq, Generic)++instance P.Pinchable AUnion+++data UnionWithVoid+    = UnionVoidBefore (G.Field 1 Int8)+    | UnionVoid G.Void+    | UnionVoidAfter (G.Field 2 Text)+  deriving (Show, Ord, Eq, Generic)++instance P.Pinchable UnionWithVoid++unionSpec :: Spec+unionSpec = describe "Union" $ do++    prop "can pinch (1)" $ \dub ->+        P.pinch (UnionDouble (G.putField dub)) `shouldBe`+            vstruct [(1, vdub_ dub)]++    prop "can pinch (2)" $ \byt ->+        P.pinch (UnionByte (G.putField byt)) `shouldBe`+            vstruct [(2, vbyt_ byt)]++    it "can pinch (3)" $+        P.pinch+          (UnionSet (G.putField $ S.fromList [EnumA G.enum, EnumB G.enum]))+            `shouldBe`+              vstruct+                [(5, vset_ [vi32 1, vi32 2])]++    it "can pinch (4)" $ do+        P.pinch (UnionVoidBefore (G.putField 42))+            `shouldBe` vstruct [(1, vbyt_ 42)]++        P.pinch (UnionVoidAfter (G.putField "foo"))+            `shouldBe` vstruct [(2, vbin_ "foo")]++        P.pinch (UnionVoid G.Void) `shouldBe` vstruct []++    it "can unpinch" $ do+        P.unpinch (vstruct [(1, vdub_ 12.34)])+            `shouldBe` Right (UnionDouble $ G.putField 12.34)++        P.unpinch (vstruct [(2, vbyt_ 123)])+            `shouldBe` Right (UnionByte $ G.putField 123)++        P.unpinch+            (vstruct [(5, vset_ [vi32 1, vi32 2])])+            `shouldBe` Right+                (UnionSet . G.putField . S.fromList+                    $ [EnumA G.enum, EnumB G.enum])++        P.unpinch (vstruct [(1, vbyt_ 42)])+            `shouldBe` Right (UnionVoidBefore $ G.putField 42)++        P.unpinch (vstruct [(2, vbin_ "foo")])+            `shouldBe` Right (UnionVoidAfter $ G.putField "foo")++        P.unpinch (vstruct []) `shouldBe` Right (UnionVoid G.Void)++    it "reject invalid types" $ do+        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(1, vi32_ 1)])+            `leftShouldContain` "is absent"++        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(2, vbool_ True)])+            `leftShouldContain` "is absent"++        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(5, vlist_ [vi32 1, vi32 2])])+            `leftShouldContain` "has the incorrect type"++    it "reject invalid IDs" $+        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(3, vdub_ 1.0)])+            `leftShouldContain` "is absent"+++data AStruct = AStruct (G.Field 1 ByteString) (G.Field 5 (Maybe Int32))+  deriving (Show, Ord, Eq, Generic)++instance P.Pinchable AStruct+++structSpec :: Spec+structSpec = describe "Struct" $ do++    it "can pinch and unpinch" $ do+        P.pinch (AStruct (G.putField "foo") (G.putField Nothing))+            `shouldBe` vstruct [(1, vbin_ "foo")]++        P.pinch (AStruct (G.putField "bar") (G.putField $ Just 42))+            `shouldBe` vstruct+                [ (1, vbin_ "bar")+                , (5, vi32_ 42)+                ]++        P.unpinch (vstruct [(1, vbin_ "hello")])+            `shouldBe` Right+                (AStruct (G.putField "hello") (G.putField Nothing))++        P.unpinch+          (vstruct+            [ (1, vbin_ "hello")+            , (5, vi32_ 42)+            ]) `shouldBe`+                Right (AStruct (G.putField "hello") (G.putField $ Just 42))++    it "ignores unrecognized fields" $ do+        P.unpinch+          (vstruct+            [ (1, vbin_ "foo")+            , (2, vi32_ 42)+            ]) `shouldBe`+                Right (AStruct (G.putField "foo") (G.putField Nothing))++        P.unpinch+          (vstruct+            [ (1, vbin_ "foo")+            , (4, vbyt_ 12)+            , (5, vi32_ 34)+            ]) `shouldBe`+                Right (AStruct (G.putField "foo") (G.putField $ Just 34))++    it "rejects missing required fields" $+        (P.unpinch :: V.Value T.TStruct -> Either String AStruct)+          (vstruct+            [ (4, vbyt_ 12)+            , (5, vi32_ 34)+            ]) `leftShouldContain` "1 is absent"++    it "rejects invalid types" $+        (P.unpinch :: V.Value T.TStruct -> Either String AStruct)+          (vstruct+            [ (1, vlist_ [vi32 42])+            ]) `leftShouldContain` "has the incorrect type"+++spec :: Spec+spec = do+    enumSpec+    unionSpec+    structSpec
+ tests/Pinch/Internal/ParserSpec.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NegativeLiterals  #-}+{-# LANGUAGE OverloadedStrings #-}+module Pinch.Internal.ParserSpec (spec) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Data.Either           (isLeft)+import Data.Word             (Word8)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import qualified Data.ByteString as B++import Pinch.Arbitrary++import qualified Pinch.Internal.Parser as P+++parse :: [Word8] -> P.Parser a -> Either String a+parse s p = P.runParser p (B.pack s)+++parseCases+    :: (Show a, Eq a)+    => P.Parser a -> [([Word8], a)] -> Expectation+parseCases parser = mapM_ . uncurry $ \bytes expected ->+    (bytes `parse` parser) `shouldBe` Right expected+++spec :: Spec+spec = describe "Parser" $ do++    it "can succeed" $+        P.runParser (return 42) "" `shouldBe` Right (42 :: Int)++    it "can fail" $+        (P.runParser (fail "great sadness") "" :: Either String ())+            `shouldBe` Left "great sadness"++    it "can parse 8-bit integers" $+        parseCases P.int8+            [ ([0x01], 1)+            , ([0x05], 5)+            , ([0x7f], 127)+            , ([0xff], -1)+            , ([0x80], -128)+            ]++    it "can parse 16-bit integers" $+        parseCases P.int16+            [ ([0x00, 0x01], 1)+            , ([0x00, 0xff], 255)+            , ([0x01, 0x00], 256)+            , ([0x01, 0x01], 257)+            , ([0x7f, 0xff], 32767)+            , ([0xff, 0xff], -1)+            , ([0xff, 0xfe], -2)+            , ([0xff, 0x00], -256)+            , ([0xff, 0x01], -255)+            , ([0x80, 0x00], -32768)+            ]++    it "can parse 32-bit integers" $+        parseCases P.int32+            [ ([0x00, 0x00, 0x00, 0x01], 1)+            , ([0x00, 0x00, 0x00, 0xff], 255)+            , ([0x00, 0x00, 0xff, 0xff], 65535)+            , ([0x00, 0xff, 0xff, 0xff], 16777215)+            , ([0x7f, 0xff, 0xff, 0xff], 2147483647)+            , ([0xff, 0xff, 0xff, 0xff], -1)+            , ([0xff, 0xff, 0xff, 0x00], -256)+            , ([0xff, 0xff, 0x00, 0x00], -65536)+            , ([0xff, 0x00, 0x00, 0x00], -16777216)+            , ([0x80, 0x00, 0x00, 0x00], -2147483648)+            ]++    it "can parse 64-bit integers" $+        parseCases P.int64+            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1)+            , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295)+            , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775)+            , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 281474976710655)+            , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 72057594037927935)+            , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 9223372036854775807)+            , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1)+            , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], -4294967296)+            , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], -1099511627776)+            , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -281474976710656)+            , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -72057594037927936)+            , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808)+            ]++    it "can parse doubles" $+        parseCases P.double+            [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0)+            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0)+            , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001)+            , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], 1.1)+            , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], -1.1)+            , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], 3.141592653589793)+            , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001)+            ]++    describe "take" $ do++        prop "returns the requested number of bytes" $+          \n (SomeByteString bs) ->+            B.length bs >= n ==>+              (B.length <$> P.runParser (P.take n) bs) === Right n++        prop "fails when input is too short" $+          \n (SomeByteString bs) ->+            B.length bs < n ==> isLeft (P.runParser (P.take n) bs)
+ tests/Pinch/Internal/PinchableSpec.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}+module Pinch.Internal.PinchableSpec (spec) where++import Control.Applicative+import Control.Monad+import Data.ByteString       (ByteString)+import Data.HashMap.Strict   (HashMap)+import Data.HashSet          (HashSet)+import Data.Int              (Int16, Int32, Int8)+import Data.Map.Strict       (Map)+import Data.Set              (Set)+import Data.Text             (Text)+import Data.Vector           (Vector)+import Test.Hspec+import Test.Hspec.QuickCheck++import qualified Data.ByteString     as B+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.Vector         as Vec++import Pinch.Arbitrary+import Pinch.Expectations+import Pinch.Internal.Pinchable ((.:), (.:?), (.=), (?=))+import Pinch.Internal.Util++import qualified Pinch.Internal.Pinchable as P+import qualified Pinch.Internal.TType     as T+import qualified Pinch.Internal.Value     as V+++data AnEnum = EnumA | EnumB | EnumC+    deriving (Show, Ord, Eq)++instance P.Pinchable AnEnum where+    type Tag AnEnum = T.TEnum++    pinch EnumA = P.pinch (1 :: Int32)+    pinch EnumB = P.pinch (2 :: Int32)+    pinch EnumC = P.pinch (3 :: Int32)++    unpinch = P.unpinch >=> \v -> case (v :: Int32) of+        1 -> Right EnumA+        2 -> Right EnumB+        3 -> Right EnumC+        _ -> Left "Unknown enum value"++enumSpec :: Spec+enumSpec = describe "Enum" $ do++    it "can pinch and unpinch" $ do+        P.pinch EnumA `shouldBe` vi32 1+        P.pinch EnumB `shouldBe` vi32 2+        P.pinch EnumC `shouldBe` vi32 3++        P.unpinch (vi32 1) `shouldBe` Right EnumA+        P.unpinch (vi32 2) `shouldBe` Right EnumB+        P.unpinch (vi32 3) `shouldBe` Right EnumC++    it "reject invalid values" $+        P.unpinch (vi32 4) `shouldBe`+            (Left "Unknown enum value" :: Either String AnEnum)+++data AUnion+    = UnionDouble Double+    | UnionByte Int8+    | UnionSet (Set AnEnum)+  deriving (Show, Ord, Eq)++instance P.Pinchable AUnion where+    type Tag AUnion = T.TUnion++    pinch (UnionDouble d) = P.union 1 d+    pinch (UnionByte i) = P.union 2 i+    pinch (UnionSet s) = P.union 5 s++    unpinch m =+            UnionDouble <$> m .: 1+        <|> UnionByte   <$> m .: 2+        <|> UnionSet    <$> m .: 5++unionSpec :: Spec+unionSpec = describe "Union" $ do++    prop "can pinch (1)" $ \dub ->+        P.pinch (UnionDouble dub) `shouldBe`+            vstruct [(1, vdub_ dub)]++    prop "can pinch (2)" $ \byt ->+        P.pinch (UnionByte byt) `shouldBe`+            vstruct [(2, vbyt_ byt)]++    it "can pinch (3)" $+        P.pinch (UnionSet $ S.fromList [EnumA, EnumB]) `shouldBe`+            vstruct [(5, vset_ [vi32 1, vi32 2])]++    it "can unpinch" $ do+        P.unpinch (vstruct [(1, vdub_ 12.34)])+            `shouldBe` Right (UnionDouble 12.34)++        P.unpinch (vstruct [(2, vbyt_ 123)])+            `shouldBe` Right (UnionByte 123)++        P.unpinch+            (vstruct [(5, vset_ [vi32 1, vi32 2])])+            `shouldBe` Right (UnionSet $ S.fromList [EnumA, EnumB])++    it "reject invalid types" $ do+        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(1, vi32_ 1)])+            `leftShouldContain` "is absent"++        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(2, vbool_ True)])+            `leftShouldContain` "is absent"++        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(5, vlist_ [vi32 1, vi32 2])])+            `leftShouldContain` "has the incorrect type"++    it "reject invalid IDs" $+        (P.unpinch :: V.Value T.TUnion -> Either String AUnion)+          (vstruct [(3, vdub_ 1.0)])+            `leftShouldContain` "is absent"+++data AStruct = AStruct ByteString (Maybe Int32)+  deriving (Show, Ord, Eq)++instance P.Pinchable AStruct where+    type Tag AStruct = T.TStruct++    pinch (AStruct a b) = P.struct [1 .= a, 5 ?= b]+    unpinch m = AStruct <$> m .: 1 <*> m .:? 5++structSpec :: Spec+structSpec = describe "Struct" $ do++    it "can pinch and unpinch" $ do+        P.pinch (AStruct "foo" Nothing)+            `shouldBe` vstruct [(1, vbin_ "foo")]++        P.pinch (AStruct "bar" (Just 42))+            `shouldBe` vstruct+                [ (1, vbin_ "bar")+                , (5, vi32_ 42)+                ]++        P.unpinch (vstruct [(1, vbin_ "hello")])+            `shouldBe` Right (AStruct "hello" Nothing)++        P.unpinch+          (vstruct+            [ (1, vbin_ "hello")+            , (5, vi32_ 42)+            ]) `shouldBe` Right (AStruct "hello" (Just 42))++    it "ignores unrecognized fields" $ do+        P.unpinch+          (vstruct+            [ (1, vbin_ "foo")+            , (2, vi32_ 42)+            ]) `shouldBe` Right (AStruct "foo" Nothing)++        P.unpinch+          (vstruct+            [ (1, vbin_ "foo")+            , (4, vbyt_ 12)+            , (5, vi32_ 34)+            ]) `shouldBe` Right (AStruct "foo" (Just 34))++    it "rejects missing required fields" $+        (P.unpinch :: V.Value T.TStruct -> Either String AStruct)+          (vstruct+            [ (4, vbyt_ 12)+            , (5, vi32_ 34)+            ]) `leftShouldContain` "1 is absent"++    it "rejects invalid types" $+        (P.unpinch :: V.Value T.TStruct -> Either String AStruct)+          (vstruct+            [ (1, vlist_ [vi32 42])+            ]) `leftShouldContain` "has the incorrect type"+++primitivesSpec :: Spec+primitivesSpec = do++    it "can pinch and unpinch Bools" $ do+        P.pinch True `shouldBe` vbool True+        P.pinch False `shouldBe` vbool False++        P.unpinch (vbool True) `shouldBe` Right True+        P.unpinch (vbool False) `shouldBe` Right False++    prop "can pinch and unpinch Int8" $ \i -> do+        P.pinch i `shouldBe` vbyt i+        P.unpinch (vbyt i) `shouldBe` Right i++    prop "can pinch and unpinch Int32" $ \i -> do+        P.pinch i `shouldBe` vi32 i+        P.unpinch (vi32 i) `shouldBe` Right i++    prop "can pinch and unpinch Int64" $ \i -> do+        P.pinch i `shouldBe` vi64 i+        P.unpinch (vi64 i) `shouldBe` Right i++    prop "can pinch and unpinch Double" $ \d -> do+        P.pinch d `shouldBe` vdub d+        P.unpinch (vdub d) `shouldBe` Right d++    prop "can pinch and unpinch ByteString" $ \(SomeByteString bs) -> do+        P.pinch bs `shouldBe` vbin bs+        P.unpinch (vbin bs) `shouldBe` Right bs++    it "can pinch and unpinch Text" $ do+        P.pinch ("☕️" :: Text)+            `shouldBe` vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f])++        P.unpinch (vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f]))+            `shouldBe` Right ("☕️" :: Text)+++containerSpec :: Spec+containerSpec = do++    describe "Vector" $ do+        it "can pinch and unpinch" $ do++            P.pinch (Vec.fromList [1, 2, 3 :: Int32])+                `shouldBe` vlist [vi32 1, vi32 2, vi32 3]++            P.unpinch (vlist [vi32 1, vi32 2, vi32 3])+                `shouldBe` Right (Vec.fromList [1, 2, 3 :: Int32])++        it "rejects type mismatch" $+          (P.unpinch :: V.Value T.TList -> Either String (Vector Int8))+            (vlist [vi32 1, vi32 2, vi32 3])+                `leftShouldContainAll`+                    ["Type mismatch", "Expected TByte", "Got TInt32"]++    describe "List" $ do++        it "can pinch and unpinch" $ do++            P.pinch ([1, 2, 3] :: [Int32])+                `shouldBe` vlist [vi32 1, vi32 2, vi32 3]++            P.unpinch (vlist [vi32 1, vi32 2, vi32 3])+                `shouldBe` Right ([1, 2, 3] :: [Int32])++        it "rejects type mismatch" $+          (P.unpinch :: V.Value T.TList -> Either String [Int8])+            (vlist [vi32 1, vi32 2, vi32 3])+                `leftShouldContain` "Type mismatch"++    describe "HashSet" $ do+        it "can pinch and unpinch" $ do++            P.pinch (HS.fromList [1, 2, 3 :: Int32])+                `shouldBe` vset [vi32 1, vi32 2, vi32 3]++            P.unpinch (vset [vi32 1, vi32 2, vi32 3])+                `shouldBe` Right (HS.fromList [1, 2, 3 :: Int32])++        it "rejects type mismatch" $+          (P.unpinch :: V.Value T.TSet -> Either String (HashSet Int8))+            (vset [vi32 1, vi32 2, vi32 3])+                `leftShouldContain` "Type mismatch"++    describe "Set" $ do+        it "can pinch and unpinch" $ do++            P.pinch (S.fromList [1, 2, 3 :: Int32])+                `shouldBe` vset [vi32 1, vi32 2, vi32 3]++            P.unpinch (vset [vi32 1, vi32 2, vi32 3])+                `shouldBe` Right (S.fromList [1, 2, 3 :: Int32])++        it "rejects type mismatch" $+          (P.unpinch :: V.Value T.TSet -> Either String (Set Int8))+            (vset [vi32 1, vi32 2, vi32 3])+                `leftShouldContain` "Type mismatch"++    describe "HashMap" $ do++        it "can pinch and unpinch" $ do++            P.pinch (HM.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)])+                `shouldBe` vmap+                    [ (vbin "a", vi16 1)+                    , (vbin "b", vi16 2)+                    ]++            P.unpinch+              (vmap [ (vbin "a", vi16 1)+                      , (vbin "b", vi16 2)+                      ]) `shouldBe`+                        Right+                          (HM.fromList+                            [("a", 1), ("b", 2) :: (ByteString, Int16)])++        it "rejects key type mismatch" $+          (P.unpinch :: V.Value T.TMap -> Either String (HashMap Int32 Int16))+              (vmap [(vbin "a", vi16 1)])+                  `leftShouldContain` "Type mismatch"++        it "rejects value type mismatch" $+          (P.unpinch :: V.Value T.TMap -> Either String (HashMap ByteString Bool))+              (vmap [(vbin "a", vi16 1)])+                  `leftShouldContain` "Type mismatch"++    describe "Map" $ do++        it "can pinch and unpinch" $ do++            P.pinch (M.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)])+                `shouldBe` vmap+                    [ (vbin "a", vi16 1)+                    , (vbin "b", vi16 2)+                    ]++            P.unpinch+              (vmap [ (vbin "a", vi16 1)+                      , (vbin "b", vi16 2)+                      ]) `shouldBe`+                        Right+                          (M.fromList+                            [("a", 1), ("b", 2) :: (ByteString, Int16)])++        it "rejects key type mismatch" $+          (P.unpinch :: V.Value T.TMap -> Either String (Map Int32 Int16))+              (vmap [(vbin "a", vi16 1)])+                  `leftShouldContain` "Type mismatch"++        it "rejects value type mismatch" $+          (P.unpinch :: V.Value T.TMap -> Either String (Map ByteString Bool))+              (vmap [(vbin "a", vi16 1)])+                  `leftShouldContain` "Type mismatch"+++spec :: Spec+spec = describe "Pinchable" $ do+    primitivesSpec+    containerSpec+    enumSpec+    unionSpec+    structSpec
+ tests/Pinch/Internal/TTypeSpec.hs view
@@ -0,0 +1,16 @@+module Pinch.Internal.TTypeSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck++import Pinch.Arbitrary ()++import qualified Pinch.Internal.TType as T++spec :: Spec+spec = describe "TType" $++    -- silly sanity test+    prop "has matching IsTType results" $ \someType ->+        case someType of+            T.SomeTType typ -> T.ttype `shouldBe` typ
+ tests/Pinch/Internal/Util.hs view
@@ -0,0 +1,105 @@+module Pinch.Internal.Util+    ( vbin+    , vbool+    , vbyt+    , vdub+    , vi16+    , vi32+    , vi64+    , vlist+    , vmap+    , vsome+    , vstruct+    , vset++    , vstruct_+    , vset_+    , vlist_+    , vmap_+    , vdub_+    , vbyt_+    , vi16_+    , vi32_+    , vi64_+    , vbool_+    , vbin_+    ) where++import Data.ByteString (ByteString)+import Data.Int++import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet        as HS+import qualified Data.Vector         as V++import Pinch.Internal.TType+import Pinch.Internal.Value++vsome :: IsTType a => Value a -> SomeValue+vsome = SomeValue++vstruct_ :: [(Int16, SomeValue)] -> SomeValue+vstruct_ = vsome . vstruct++vset_ :: IsTType a => [Value a] -> SomeValue+vset_ = vsome . vset++vlist_ :: IsTType a => [Value a] -> SomeValue+vlist_ = vsome . vlist++vmap_ :: (IsTType k, IsTType v) => [(Value k, Value v)] -> SomeValue+vmap_ = vsome . vmap++vdub_ :: Double -> SomeValue+vdub_ = vsome . vdub++vbyt_ :: Int8 -> SomeValue+vbyt_ = vsome . vbyt++vi16_ :: Int16 -> SomeValue+vi16_ = vsome . vi16++vi32_ :: Int32 -> SomeValue+vi32_ = vsome . vi32++vi64_ :: Int64 -> SomeValue+vi64_ = vsome . vi64++vbool_ :: Bool -> SomeValue+vbool_ = vsome . vbool++vbin_ :: ByteString -> SomeValue+vbin_ = vsome . vbin++vstruct :: [(Int16, SomeValue)] -> Value TStruct+vstruct = VStruct . HM.fromList++vset :: IsTType a => [Value a] -> Value TSet+vset = VSet . HS.fromList++vlist :: IsTType a => [Value a] -> Value TList+vlist = VList . V.fromList++vmap :: (IsTType k, IsTType v) => [(Value k, Value v)] -> Value TMap+vmap = VMap . HM.fromList++vdub :: Double -> Value TDouble+vdub = VDouble++vbyt :: Int8 -> Value TByte+vbyt = VByte++vi16 :: Int16 -> Value TInt16+vi16 = VInt16++vi32 :: Int32 -> Value TInt32+vi32 = VInt32++vi64 :: Int64 -> Value TInt64+vi64 = VInt64++vbool :: Bool -> Value TBool+vbool = VBool++vbin :: ByteString -> Value TBinary+vbin = VBinary
+ tests/Pinch/Internal/ValueSpec.hs view
@@ -0,0 +1,18 @@+module Pinch.Internal.ValueSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Pinch.Arbitrary ()++import qualified Pinch.Internal.Value as V++spec :: Spec+spec = describe "Value" $ do++    prop "is equal to itself" $ \(V.SomeValue v) ->+        v === v++    prop "can be cast via SomeValue" $ \(V.SomeValue v) ->+        V.castValue (V.SomeValue v) === Just v
+ tests/Pinch/Protocol/BinarySpec.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Pinch.Protocol.BinarySpec (spec) where++import Data.ByteString       (ByteString)+import Data.ByteString.Lazy  (toStrict)+import Data.Word             (Word8)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import qualified Data.ByteString         as B+import qualified Data.ByteString.Builder as BB++import Pinch.Arbitrary        ()+import Pinch.Internal.Message+import Pinch.Internal.TType+import Pinch.Internal.Util+import Pinch.Internal.Value   (SomeValue (..), Value (..))+import Pinch.Protocol         (Protocol (..))+import Pinch.Protocol.Binary  (binaryProtocol)+++serialize :: IsTType a => Value a -> ByteString+serialize = toStrict . BB.toLazyByteString . snd . serializeValue binaryProtocol+++deserialize :: IsTType a => ByteString -> Either String (Value a)+deserialize = deserializeValue binaryProtocol+++serializeMsg :: Message -> ByteString+serializeMsg =+    toStrict . BB.toLazyByteString . snd . serializeMessage binaryProtocol++deserializeMsg :: ByteString -> Either String Message+deserializeMsg = deserializeMessage binaryProtocol+++-- | For each given pair, verifies that parsing the byte array yields the+-- value, and that serializing the value yields the byte array.+readWriteCases :: IsTType a => [([Word8], Value a)] -> Expectation+readWriteCases = mapM_ . uncurry $ \bytes value -> do+    let bs = B.pack bytes+    deserialize bs  `shouldBe` Right value+    serialize value `shouldBe` bs+++readWriteMessageCases :: [([Word8], Message)] -> Expectation+readWriteMessageCases = mapM_ . uncurry $ \bytes msg -> do+    let bs = B.pack bytes+    deserializeMsg bs  `shouldBe` Right msg+    serializeMsg msg `shouldBe` bs+++readMessageCases :: [([Word8], Message)] -> Expectation+readMessageCases = mapM_ . uncurry $ \bytes msg ->+    deserializeMsg (B.pack bytes)  `shouldBe` Right msg+++-- | For each pair, verifies that if the given TType is parsed, the request+-- fails to parse because the type ID was invalid.+invalidTypeIDCases :: [(SomeTType, [Word8])] -> Expectation+invalidTypeIDCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v+  where+    go :: forall a. IsTType a => TType a -> [Word8] -> Expectation+    go _ bytes =+        case deserialize (B.pack bytes) :: Either String (Value a) of+            Right v -> expectationFailure $+              "Expected " ++ show bytes ++ " to fail to parse. " +++              "Got: " ++ show v+            Left msg -> msg `shouldContain` "Unknown TType"+++-- | For each pair, verifies that if the given TType is parsed, the request+-- fails to parse because the input was too short.+tooShortCases :: [(SomeTType, [Word8])] -> Expectation+tooShortCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v+  where+    go :: forall a. IsTType a => TType a -> [Word8] -> Expectation+    go _ bytes =+        case deserialize (B.pack bytes) :: Either String (Value a) of+            Right v -> expectationFailure $+              "Expected " ++ show bytes ++ " to fail to parse. " +++              "Got: " ++ show v+            Left msg -> msg `shouldContain` "Input is too short"+++spec :: Spec+spec = describe "BinaryProtocol" $ do++    prop "can roundtrip values" $ \(SomeValue someVal) ->+        deserialize (serialize someVal) === Right someVal++    prop "can roundtrip messages" $ \(msg :: Message) ->+        deserializeMsg (serializeMsg msg) == Right msg++    it "can read and write booleans" $ readWriteCases+        [ ([0x01], vbool True)+        , ([0x00], vbool False)+        ]++    it "can read and write binary" $ readWriteCases+        [ ([ 0x00, 0x00, 0x00, 0x00 ], vbin "")+        , ([ 0x00, 0x00, 0x00, 0x05        -- length = 5+           , 0x68, 0x65, 0x6c, 0x6c, 0x6f  -- hello+           ], vbin "hello")+        ]++    it "can read and write structs" $ readWriteCases+        [ ([0x00], vstruct [])++        , ([ 0x08                    -- ttype = i32+           , 0x00, 0x01              -- field ID = 1+           , 0x00, 0x00, 0x00, 0x2a  -- 42+           , 0x00                    -- stop+           ], vstruct [(1, vi32_ 42)])++        , ([ 0x0F       -- ttype = list+           , 0x00, 0x02 -- field ID = 2++           , 0x0B                    -- ttype binary+           , 0x00, 0x00, 0x00, 0x02  -- size = 2++           , 0x00, 0x00, 0x00, 0x03  -- length = 3+           , 0x66, 0x6f, 0x6f        -- foo++           , 0x00, 0x00, 0x00, 0x03  -- length = 3+           , 0x62, 0x61, 0x72        -- bar++           , 0x00+           ], vstruct+           [ (2, vlist_ [vbin "foo", vbin "bar"])+           ])+        ]++    it "can read and write maps" $ readWriteCases+        [ ([ 0x02, 0x03              -- ktype = bool, vtype = byte+           , 0x00, 0x00, 0x00, 0x00  -- count = 0+           ], vmap ([] :: [(Value TBool, Value TByte)]))+        , ([ 0x0B, 0x0F              -- ktype = binary, vtype = list+           , 0x00, 0x00, 0x00, 0x01  -- count = 1++           -- "world"+           , 0x00, 0x00, 0x00, 0x05        -- length = 5+           , 0x77, 0x6f, 0x72, 0x6c, 0x64  -- world++           -- [1, 2, 3]+           , 0x03                          -- type = byte+           , 0x00, 0x00, 0x00, 0x03        -- count = 3+           , 0x01, 0x02, 0x03              -- 1, 2, 3+           ], vmap+           [ (vbin "world", vlist [vbyt 1, vbyt 2, vbyt 3])+           ])+        ]++    it "can read and write sets" $ readWriteCases+        [ ([0x02, 0x00, 0x00, 0x00, 0x00+           ], vset ([] :: [Value TBool]))+        , ([ 0x02+           , 0x00, 0x00, 0x00, 0x01+           , 0x01+           ], vset [vbool True])+        ]++    it "can read and write lists" $ readWriteCases+        [ ([0x02, 0x00, 0x00, 0x00, 0x00+           ], vlist ([] :: [Value TBool]))+        , ([ 0x02+           , 0x00, 0x00, 0x00, 0x05+           , 0x01, 0x00, 0x00, 0x01, 0x01+           ], vlist+               [ vbool True+               , vbool False+               , vbool False+               , vbool True+               , vbool True+               ])+        ]++    it "fails if the input is too short" $ tooShortCases+        [ (SomeTType TBool, [])+        , (SomeTType TByte, [])+        , (SomeTType TInt16, [0x01])+        , (SomeTType TInt32, [0x01, 0x02, 0x03])+        , (SomeTType TInt64, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07])+        , (SomeTType TDouble, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07])+        , (SomeTType TBinary, [0x00, 0x00, 0x00])+        , (SomeTType TBinary, [0x00, 0x00, 0x00, 0x01])+        , (SomeTType TBinary, [0x00, 0x00, 0x00, 0x02, 0x01])++        , (SomeTType TMap, [0x02])+        , (SomeTType TMap, [0x02, 0x03])+        , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00])+        , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00, 0x01])+        , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00, 0x01, 0x01])+        , (SomeTType TMap,+           [0x02, 0x03, 0x00, 0x00, 0x00, 0x02, 0x01, 0x01, 0x01])++        , (SomeTType TSet, [0x02])+        , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00])+        , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00, 0x01])+        , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00, 0x02, 0x01])++        , (SomeTType TList, [0x02])+        , (SomeTType TList, [0x02, 0x00, 0x00, 0x00])+        , (SomeTType TList, [0x02, 0x00, 0x00, 0x00, 0x01])+        , (SomeTType TList, [0x02, 0x00, 0x00, 0x00, 0x02, 0x01])+        ]++    it "denies invalid type IDs" $ invalidTypeIDCases+        [ (SomeTType TStruct, [0x01, 0x00, 0x01])+        , (SomeTType TMap, [0x05, 0x07, 0x00, 0x00, 0x00, 0x00])+        , (SomeTType TSet, [0x09, 0x00, 0x00, 0x00, 0x00])+        , (SomeTType TList, [0x10, 0x00, 0x00, 0x00, 0x00])+        ]++    it "can read and write messages" $ readWriteMessageCases+        [ ([ 0x00, 0x00, 0x00, 0x06                 -- length = 6+           , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f     -- 'getFoo'+           , 0x01                                   -- type = Call+           , 0x00, 0x00, 0x00, 0x2a                 -- seqId = 42+           , 0x00                                   -- empty struct+           ], Message "getFoo" Call 42 (vstruct [])),+          ([ 0x00, 0x00, 0x00, 0x06                 -- length = 6+           , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72     -- 'setBar'+           , 0x02                                   -- type = Reply+           , 0x00, 0x00, 0x00, 0x01                 -- seqId = 1+           , 0x00+           ], Message "setBar" Reply 1 (vstruct []))+        ]++    it "can read strict messages" $ readMessageCases+        [ ([ 0x80, 0x01     -- version = 1+           , 0x00, 0x03     -- type = Exception++           , 0x00, 0x00, 0x00, 0x06              -- length = 6+           , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f  -- 'getFoo'++           , 0x00, 0x00, 0x00, 0x2a  -- seqId = 42++           , 0x02, 0x00, 0x01, 0x01  -- {1: True}+           , 0x00+           ], Message "getFoo" Exception 42 (vstruct [(1, vbool_ True)]))+        , ([ 0x80, 0x01     -- version = 1+           , 0x00, 0x04     -- type = EXCEPTION++           , 0x00, 0x00, 0x00, 0x06              -- length = 6+           , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72  -- 'setBar'++           , 0x00, 0x00, 0x00, 0x01  -- seqId = 1++           , 0x00+           ], Message "setBar" Oneway 1 (vstruct []))+        ]
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}