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