diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,4 @@ +0.1.0.0 +======= + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Abhinav Gupta + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Abhinav Gupta nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Pinch.hs b/Pinch.hs new file mode 100644 --- /dev/null +++ b/Pinch.hs @@ -0,0 +1,525 @@ +{-# 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(..) + + -- ** Automatically deriving instances + + -- | Pinch supports deriving instances of 'Pinchable' automatically for + -- types that implement the @Generic@ typeclass provided that they follow + -- the outlined patterns in their constructors. + + -- *** Structs and exceptions + -- $genericStruct + + -- *** Unions + -- $genericUnion + + , Field(..) + , getField + , putField + , field + + , Void(..) + + -- *** Enums + -- $genericEnum + + , Enumeration(..) + , enum + + -- ** Manually writing instances + + -- | Instances of 'Pinchable' can be constructed by composing together + -- existing instances and using the '.=', '.:', etc. helpers. + + -- *** Structs and exceptions + -- $struct + + -- *** Unions + -- $union + + -- *** Enums + -- $enum + + -- ** Helpers + + -- *** @pinch@ + + , (.=) + , (?=) + , struct + , union + , FieldPair + + -- *** @unpinch@ + + , (.:) + , (.:?) + + -- * Value + + -- | 'Value' is an intermediate representation of Thrift payloads tagged + -- with TType tags. Types that want to be serialized into\/deserialized + -- from Thrift payloads need only define a way to convert themselves to + -- and from 'Value' objects via 'Pinchable'. + + , Value + , SomeValue(..) + + -- * Messages + + , Message + , mkMessage + , messageName + , messageType + , messageId + , getMessageBody + + , MessageType(..) + + -- * Protocols + + , Protocol + , binaryProtocol + + -- * TType + + -- | TType is used to refer to the Thrift protocol-level type of a value. + + , TType + , IsTType(..) + + -- ** Tags + + -- | TType tags allow writing code that depends on knowing the @TType@ of + -- values, or asserting conditions on it, at compile time. + -- + -- For example, values in a map, list, or set must all have the same TType. + -- This is enforced at the type level by parameterizing 'Value' over these + -- tags. + + , TBool + , TByte + , TDouble + , TEnum + , TInt16 + , TInt32 + , TInt64 + , TBinary + , TStruct + , TUnion + , TException + , TMap + , TSet + , TList + ) where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Int (Int32) +import Data.Text (Text) + +import qualified Data.ByteString.Builder as BB + +import Pinch.Internal.Generic +import Pinch.Internal.Message +import Pinch.Internal.Pinchable +import Pinch.Internal.TType +import Pinch.Internal.Value +import Pinch.Protocol +import Pinch.Protocol.Binary + +builderToStrict :: BB.Builder -> ByteString +builderToStrict = toStrict . BB.toLazyByteString +{-# INLINE builderToStrict #-} + +-- TODO we know the size of the serialized payload. can probably pre-allocate +-- the byte string before filling it with the contents of the builder. + +------------------------------------------------------------------------------ + +-- $encodeDecodeValues +-- +-- Types that can be serialized and deserialized into\/from Thrift values +-- implement the 'Pinchable' typeclass. Instances may be derived automatically +-- using generics, or written out by hand. +-- +-- The 'Pinchable' typeclass converts objects into and from 'Value' objects, +-- which act as a direct mapping to the Thrift wire representation. A +-- 'Protocol' is responsible for converting 'Value' objects to and from +-- bytestrings. +-- +-- The 'encode' and 'decode' methods may be used on objects that implement the +-- 'Pinchable' typeclass to get the wire representation directly. +-- +-- > +------------+ Pinchable Protocol +------------+ +-- > | | +------------+ | | +-- > | +----pinch------> +---serialize---> | +-- > | Your Type | | Value a | | ByteString | +-- > | <---unpinch-----+ <--deserialize--+ | +-- > | | +------------+ | | +-- > | | | | +-- > | +-------------------encode-------------------> | +-- > | | | | +-- > | <-------------------decode-------------------+ | +-- > +------------+ +------------+ + +-- | Encode the given 'Pinchable' value using the given 'Protocol'. +-- +-- >>> unpack $ encode binaryProtocol ["a" :: ByteString, "b"] +-- [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98] +-- +encode :: Pinchable a => Protocol -> a -> ByteString +encode p = builderToStrict . snd . serializeValue p . pinch +{-# INLINE encode #-} + +-- | Decode a 'Pinchable' value from the using the given 'Protocol'. +-- +-- >>> let s = pack [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98] +-- >>> decode binaryProtocol s :: Either String [ByteString] +-- Right ["a","b"] +-- +decode :: Pinchable a => Protocol -> ByteString -> Either String a +decode p = deserializeValue p >=> unpinch +{-# INLINE decode #-} + +------------------------------------------------------------------------------ + +-- $rpc +-- +-- Thrift requests implicitly form a struct and responses implicitly form a +-- union. To send\/receive the request\/response, it must be wrapped inside a +-- 'Message'. The 'Message' contains information like the method name, the +-- message ID (to match out of order responses with requests), and whether +-- it contains a request or a response. +-- +-- Requests and responses may be wrapped into @Message@ objects using the +-- 'mkMessage' function. The message body can be retrieved back using the +-- 'getMessageBody' function. The 'encodeMessage' and 'decodeMessage' +-- functions may be used to encode and decode messages into\/from bytestrings. +-- +-- Consider the service method, +-- +-- > User getUser(1: string userName, 2: list 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 = builderToStrict . snd . serializeMessage p +{-# INLINE encodeMessage #-} + +-- | Decode a 'Message' using the given 'Protocol'. +-- +-- >>> decodeMessage binaryProtocol bs >>= getMessageBody :: Either String GetUserRequest +-- Right (GetUserRequest {userName = Field "jsmith", userAttributes = Field []}) +-- +decodeMessage :: Protocol -> ByteString -> Either String Message +decodeMessage = deserializeMessage +{-# INLINE decodeMessage #-} + +-- | Build a @Message@. +mkMessage + :: (Pinchable a, Tag a ~ TStruct) + => Text + -- ^ Name of the target method. + -> MessageType + -- ^ Type of the message. + -> Int32 + -- ^ Message ID. + -> a + -- ^ Message payload. This must be an object which serializes into a + -- struct. + -> Message +mkMessage name typ mid body = Message name typ mid (pinch body) +{-# INLINE mkMessage #-} + +-- | Read the message contents. +-- +-- This returns a @Left@ result if the message contents do not match the +-- requested type. +getMessageBody + :: (Pinchable a, Tag a ~ TStruct) => Message -> Either String a +getMessageBody = unpinch . messagePayload +{-# INLINE getMessageBody #-} + +------------------------------------------------------------------------------ + +-- $genericStruct +-- +-- Given the struct, +-- +-- > struct User { +-- > 1: required string name +-- > 2: optional string emailAddress +-- > } +-- +-- A @Pinchable@ instance for it can be automatically derived by wrapping +-- fields of the data type with the 'Field' type and specifying the field +-- identifier as a type-level numeral. Fields which hold a @Maybe@ value are +-- considered optional. +-- +-- @ +-- data User = User +-- { userName :: 'Field' 1 Text +-- , userEmailAddress :: Field 2 (Maybe Text) +-- } +-- deriving (Generic) +-- +-- instance Pinchable User +-- @ +-- +-- The @DeriveGeneric@ extension is required to automatically derive instances +-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use +-- type-level numerals. + +------------------------------------------------------------------------------ + +-- $genericUnion +-- +-- As with structs and exceptions, fields of the data type representing a +-- union must be tagged with 'Field', but to satisfy the property of a union +-- that only one value is set at a time, they must be on separate +-- constructors. +-- +-- For example, given the union, +-- +-- > union Item { +-- > 1: binary bin +-- > 2: string str +-- > 3: i32 int +-- > } +-- +-- A @Pinchable@ instance can be derived like so, +-- +-- > data Item +-- > = ItemBin (Field 1 ByteString) +-- > | ItemStr (Field 2 Text) +-- > | ItemInt (Field 3 Int32) +-- > deriving (Generic) +-- > +-- > instance Pinchable Item +-- +-- The @DeriveGeneric@ extension is required to automatically derive instances +-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use +-- type-level numerals. +-- +-- If the union represents the response of a service method which returns a +-- @void@ result, the type 'Void' may be used. +-- +-- @ +-- data GetFooResponse +-- = GetFooDoesNotExist (Field 1 FooDoesNotExist) +-- | GetFooInternalError (Field 2 InternalError) +-- | GetFooSuccess 'Void' +-- @ + +------------------------------------------------------------------------------ + +-- $genericEnum +-- +-- Given the enum, +-- +-- > enum Op { +-- > Add, Sub, Mul, Div +-- > } +-- +-- A @Pinchable@ instance can be derived for it by creating one constructor +-- for each of the enum values and providing it a single 'Enumeration' +-- argument tagged with the enum value. +-- +-- @ +-- data Op +-- = OpAdd ('Enumeration' 0) +-- | OpSub (Enumeration 1) +-- | OpMul (Enumeration 2) +-- | OpDiv (Enumeration 3) +-- deriving (Generic) +-- +-- instance Pinchable Op +-- @ +-- +-- Note that you need to know the values assigned to the enums. If not +-- specified, Thrift automatically assigns incrementing values to the items in +-- the order they appear starting at 0. +-- +-- The @DeriveGeneric@ extension is required to automatically derive instances +-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use +-- type-level numerals. + +------------------------------------------------------------------------------ + +-- $struct +-- +-- Given a Thrift struct, +-- +-- > struct Post { +-- > 1: optional string subject +-- > 2: required string body +-- > } +-- +-- The 'Pinchable' instance for it will be, +-- +-- @ +-- data Post = Post +-- { postSubject :: Maybe Text +-- , postBody :: Text +-- } +-- +-- instance 'Pinchable' Post where +-- type 'Tag' Post = 'TStruct' +-- +-- pinch (Post subject body) = +-- 'struct' [ 1 '?=' subject +-- , 2 '.=' body +-- ] +-- +-- unpinch value = +-- Post \<$\> value '.:?' 1 +-- \<*\> value '.:' 2 +-- @ +-- + +------------------------------------------------------------------------------ + +-- $union +-- +-- Given a Thrift union, +-- +-- > union PostBody { +-- > 1: string markdown +-- > 2: binary rtf +-- > } +-- +-- The 'Pinchable' instance for it will be, +-- +-- @ +-- data PostBody +-- = PostBodyMarkdown Text +-- | PostBodyRtf ByteString +-- +-- instance Pinchable PostBody where +-- type Tag PostBody = 'TUnion' +-- +-- pinch (PostBodyMarkdown markdownBody) = +-- 'union' 1 markdownBody +-- pinch (PostBodyRtf rtfBody) = +-- union 2 rtfBody +-- +-- unpinch v = PostBodyMarkdown \<$\> v .: 1 +-- \<|\> PostBodyRtf \<$\> v .: 2 +-- @ + +------------------------------------------------------------------------------ + +-- $enum +-- +-- Given an enum, +-- +-- > enum Role { +-- > DISABLED = 0, +-- > USER, +-- > ADMIN, +-- > } +-- +-- The 'Pinchable' instance for it will be, +-- +-- > data Role = RoleDisabled | RoleUser | RoleAdmin +-- > +-- > instance Pinchable Role where +-- > type Tag Role = TEnum +-- > +-- > pinch RoleDisabled = pinch (0 :: Int32) +-- > pinch RoleUser = pinch (1 :: Int32) +-- > pinch RoleAdmin = pinch (2 :: Int32) +-- > +-- > unpinch v = do +-- > value <- unpinch v +-- > case (value :: Int32) of +-- > 0 -> Right RoleDisabled +-- > 1 -> Right RoleUser +-- > 2 -> Right RoleAdmin +-- > _ -> Left $ "Unknown role: " ++ show value diff --git a/Pinch/Internal/Builder.hs b/Pinch/Internal/Builder.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Builder.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Pinch.Internal.Builder +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module provides a wrapper around @Data.ByteString.Builder@ that keeps +-- track of the final size of the generated ByteString. +module Pinch.Internal.Builder + ( Builder + , Build + , run + + , int8 + , int16 + , int32 + , int64 + , double + , byteString + ) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Data.ByteString (ByteString) +import Data.Int +import Data.Monoid +import Prelude hiding (length) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB + +-- | Alias for a build that produces no results. +type Build = Builder () + +-- We're using big endian byte order for now. We can add little endian later +-- if needed. + +-- | Used for building a long chain of ByteStrings. +data Builder a = B !a {-# UNPACK #-} !Int64 !BB.Builder + -- TODO CPS? + +instance Functor Builder where + fmap f (B a l b) = B (f a) l b + +instance Applicative Builder where + pure a = B a 0 mempty + B f l0 b0 <*> B a l1 b1 = B (f a) (l0 + l1) (b0 <> b1) + +instance Monad Builder where + (>>) = (*>) + return = pure + B a l0 b0 >>= k = + let B b l1 b1 = k a + in B b (l0 + l1) (b0 <> b1) + +-- | Returns the ByteString Builder for this build and its length. +run :: Build -> (Int64, BB.Builder) +run (B () l b) = (l, b) + + +-- | Writes a byte. +int8 :: Int8 -> Build +int8 = B () 1 . BB.int8 + + +-- | Writes a 16-bit integer. +int16 :: Int16 -> Build +int16 = B () 2 . BB.int16BE + + +-- | Writes a 32-bit integer. +int32 :: Int32 -> Build +int32 = B () 4 . BB.int32BE + + +-- | Writes a 64-bit integer. +int64 :: Int64 -> Build +int64 = B () 8 . BB.int64BE + + +-- | Writes a 64-bit double. +double :: Double -> Build +double = B () 8 . BB.doubleBE + + +-- | Writes an arbitrary ByteString. +byteString :: ByteString -> Build +byteString bs = B () (fromIntegral $ B.length bs) (BB.byteString bs) diff --git a/Pinch/Internal/Generic.hs b/Pinch/Internal/Generic.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Generic.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ < 709 +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE +#else +#define OVERLAPPABLE {-# OVERLAPPABLE #-} +#endif +-- | +-- Module : Pinch.Internal.Generic +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Implements support for automatically deriving Pinchable instances for types +-- that implement @Generic@ and follow a specific pattern. +-- +module Pinch.Internal.Generic + ( Field(..) + , getField + , putField + , field + + , Enumeration(..) + , enum + + , Void(..) + ) where + + +#if __GLASGOW_HASKELL__ < 709 +import Data.Foldable (Foldable) +import Data.Monoid (Monoid) +import Data.Traversable (Traversable) +#endif + +import Control.Applicative +import Control.DeepSeq (NFData) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import GHC.Generics +import GHC.TypeLits + +import qualified Data.HashMap.Strict as HM + +import Pinch.Internal.Pinchable +import Pinch.Internal.TType +import Pinch.Internal.Value (Value (..)) + + +-- | Implemented by TType tags whose values know how to combine. +class Combinable t where + combine :: Value t -> Value t -> Value t + +instance Combinable TStruct where + combine (VStruct as) (VStruct bs) = VStruct $ as `HM.union` bs + + +instance OVERLAPPABLE GPinchable a => GPinchable (M1 i c a) where + type GTag (M1 i c a) = GTag a + gPinch = gPinch . unM1 + gUnpinch = fmap M1 . gUnpinch + + +-- Adds the name of the data type to the error message. +instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where + type GTag (D1 d a) = GTag a + gPinch = gPinch . unM1 + gUnpinch v = case gUnpinch v of + Left msg -> Left $ "Failed to read '" ++ name ++ "': " ++ msg + Right a -> Right $ M1 a + where + name = datatypeName (undefined :: D1 d a b) + +instance + ( GPinchable a + , GPinchable b + , GTag a ~ GTag b + , Combinable (GTag a) + ) => GPinchable (a :*: b) where + type GTag (a :*: b) = GTag a + gPinch (a :*: b) = gPinch a `combine` gPinch b + gUnpinch m = (:*:) <$> gUnpinch m <*> gUnpinch m + +instance + ( GPinchable a + , GPinchable b + , GTag a ~ GTag b + ) => GPinchable (a :+: b) where + type GTag (a :+: b) = GTag a + gPinch (L1 a) = gPinch a + gPinch (R1 b) = gPinch b + gUnpinch m = L1 <$> gUnpinch m <|> R1 <$> gUnpinch m + +------------------------------------------------------------------------------ + +-- | Fields of data types that represent structs, unions, and exceptions +-- should be wrapped inside 'Field' and tagged with the field identifier. +-- +-- > data Foo = Foo (Field 1 Text) (Field 2 (Maybe Int32)) deriving Generic +-- > instance Pinchable Foo +-- +-- > data A = A (Field 1 Int32) | B (Field 2 Text) deriving Generic +-- > instance Pinchable Foo +-- +-- Fields which hold @Maybe@ values are treated as optional. All fields values +-- must be 'Pinchable' to automatically derive a @Pinchable@ instance for the +-- new data type. +newtype Field (n :: Nat) a = Field a + deriving + (Bounded, Eq, Enum, Foldable, Functor, Generic, Monoid, NFData, Ord, Show, + Traversable, Typeable) + +-- | Gets the current value of a field. +-- +-- > let Foo a' _ = {- ... -} +-- > a = getField a' +getField :: Field n a -> a +getField (Field a) = a + +-- | Puts a value inside a field. +-- +-- > Foo (putField "Hello") (putField (Just 42)) +putField :: a -> Field n a +putField = Field + +-- | A lens on @Field@ wrappers for use with the lens library. +-- +-- > person & name . field .~ "new value" +-- +field :: Functor f => (a -> f b) -> Field n a -> f (Field n b) +field f (Field a) = Field <$> f a + +instance OVERLAPPABLE (Pinchable a, KnownNat n) + => GPinchable (K1 i (Field n a)) where + type GTag (K1 i (Field n a)) = TStruct + gPinch (K1 (Field a)) = struct [n .= a] + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + + gUnpinch m = K1 . Field <$> m .: n + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + +instance + (Pinchable a, KnownNat n) + => GPinchable (K1 i (Field n (Maybe a))) where + type GTag (K1 i (Field n (Maybe a))) = TStruct + gPinch (K1 (Field a)) = struct [n ?= a] + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + + gUnpinch m = K1 . Field <$> m .:? n + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + +------------------------------------------------------------------------------ + +-- | Data types that represent Thrift enums must have one constructor for each +-- enum item accepting an 'Enumeration' object tagged with the corresponding +-- enum value. +-- +-- > data Role = RoleUser (Enumeration 1) | RoleAdmin (Enumeration 2) +-- > deriving Generic +-- > instance Pinchable Role +data Enumeration (n :: Nat) = Enumeration + deriving + (Eq, Generic, Ord, Show, Typeable) + +instance NFData (Enumeration n) + +-- | Convenience function to construct 'Enumeration' objects. +-- +-- > let role = RoleUser enum +enum :: Enumeration n +enum = Enumeration + +instance KnownNat n => GPinchable (K1 i (Enumeration n)) where + type GTag (K1 i (Enumeration n)) = TEnum + gPinch (K1 Enumeration) = VInt32 . fromIntegral $ natVal (Proxy :: Proxy n) + gUnpinch (VInt32 i) + | i == val = return (K1 Enumeration) + | otherwise = Left $ "Couldn't match enum value " ++ show i + where + val = fromIntegral $ natVal (Proxy :: Proxy n) + gUnpinch x = Left $ "Failed to read enum. Got " ++ show x + +------------------------------------------------------------------------------ + +-- | Represents a @void@ result for methods. +-- +-- This should be used as an element in a response union along with 'Field' +-- tags. +-- +-- For a method, +-- +-- > void setValue(..) throws +-- > (1: ValueAlreadyExists alreadyExists, +-- > 2: InternalError internalError) +-- +-- Something similar to the following can be used. +-- +-- > data SetValueResponse +-- > = SetValueAlreadyExists (Field 1 ValueAlreadyExists) +-- > | SetValueInternalError (Field 2 InternalError) +-- > | SetValueSuccess Void +-- > deriving (Generic) +-- > +-- > instance Pinchable SetValueResponse +data Void = Void + deriving + (Eq, Generic, Ord, Show, Typeable) + +instance GPinchable (K1 i Void) where + type GTag (K1 i Void) = TStruct + + gPinch (K1 Void) = struct [] + + -- If the map isn't empty, there's probably an exception in there. + gUnpinch (VStruct m) | HM.null m = Right $ K1 Void + gUnpinch x = Left $ + "Failed to read response. Expected void, got: " ++ show x diff --git a/Pinch/Internal/Message.hs b/Pinch/Internal/Message.hs new file mode 100644 --- /dev/null +++ b/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/Pinch/Internal/Parser.hs b/Pinch/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Parser.hs @@ -0,0 +1,168 @@ +{-# 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 (shiftL, (.|.)) +import Data.ByteString (ByteString) +import Data.Int (Int16, Int32, Int64, Int8) +import Prelude hiding (take) + +import qualified Control.Monad.ST as ST +import qualified Data.Array.ST as A +import qualified Data.Array.Unsafe as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as BU + + +-- | Failure continuation. Called with the failure message. +type Failure r = String -> r +type Success a r = ByteString -> a -> r +-- ^ Success continuation. Called with the remaining bytestring and the +-- result. + +-- | A simple ByteString parser. +newtype Parser a = Parser + { unParser :: forall r. + ByteString -- Bytestring being parsed + -> Failure r -- Failure continuation + -> Success a r -- Success continuation + -> r + } + + +instance Functor Parser where + fmap f (Parser g) = Parser + $ \b0 kFail kSucc -> g b0 kFail + $ \b1 a -> kSucc b1 (f a) + + +instance Applicative Parser where + pure a = Parser $ \b _ kSucc -> kSucc b a + + Parser f' <*> Parser a' = Parser + $ \b0 kFail kSucc -> f' b0 kFail + $ \b1 f -> a' b1 kFail + $ \b2 a -> kSucc b2 (f a) + + +instance Monad Parser where + return = pure + (>>) = (*>) + + fail msg = Parser $ \_ kFail _ -> kFail msg + + Parser m >>= k = Parser + $ \b0 kFail kSucc -> m b0 kFail + $ \b1 a -> unParser (k a) b1 kFail kSucc + + +-- | Run the parser on the given ByteString. Return either the failure message +-- or the result. +runParser :: Parser a -> ByteString -> Either String a +runParser (Parser f) b = f b Left (const Right) +{-# INLINE runParser #-} + + +-- | @take n@ gets exactly @n@ bytes or fails the parse. +take :: Int -> Parser ByteString +take n = Parser $ \b kFail kSucc -> + let l = B.length b + in if l >= n + then let remaining = BU.unsafeDrop n b + requested = BU.unsafeTake n b + in kSucc remaining requested + else kFail + ("Input is too short. Expected " ++ show n ++ " bytes. " ++ + "Got " ++ show l ++ " bytes.") +{-# INLINE take #-} + + +-- | Produces the next byte and advances the parser. +int8 :: Parser Int8 +int8 = Parser + $ \b0 kFail kSucc -> case B.uncons b0 of + Nothing -> kFail "Input is too short. Expected 1 bytes. Got 0 bytes." + Just (w, b1) -> kSucc b1 (fromIntegral w) +{-# INLINE int8 #-} + + +-- | Produces a signed 16-bit integer and advances the parser. +int16 :: Parser Int16 +int16 = mk <$> take 2 + where + {-# INLINE mk #-} + mk b = + (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 8) .|. + fromIntegral (b `BU.unsafeIndex` 1) +{-# INLINE int16 #-} + + +-- | Produces a signed 32-bit integer and advances the parser. +int32 :: Parser Int32 +int32 = mk <$> take 4 + where + {-# INLINE mk #-} + mk b = + (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 24) .|. + (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 16) .|. + (fromIntegral (b `BU.unsafeIndex` 2) `shiftL` 8) .|. + fromIntegral (b `BU.unsafeIndex` 3) +{-# INLINE int32 #-} + + +-- | Produces a signed 64-bit integer and advances the parser. +int64 :: Parser Int64 +int64 = mk <$> take 8 + where + {-# INLINE mk #-} + mk b = + (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 56) .|. + (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 48) .|. + (fromIntegral (b `BU.unsafeIndex` 2) `shiftL` 40) .|. + (fromIntegral (b `BU.unsafeIndex` 3) `shiftL` 32) .|. + (fromIntegral (b `BU.unsafeIndex` 4) `shiftL` 24) .|. + (fromIntegral (b `BU.unsafeIndex` 5) `shiftL` 16) .|. + (fromIntegral (b `BU.unsafeIndex` 6) `shiftL` 8) .|. + fromIntegral (b `BU.unsafeIndex` 7) +{-# INLINE int64 #-} + + +-- | Produces a 64-bit floating point number and advances the parser. +double :: Parser Double +double = do + i <- int64 + return (ST.runST (cast i)) +{-# INLINE double #-} + + +cast :: (A.MArray (A.STUArray s) a (ST s), + A.MArray (A.STUArray s) b (ST s)) => a -> ST s b +-- As per: http://stackoverflow.com/a/7002812 +cast x = A.newArray (0 :: Int, 0) x >>= A.castSTUArray >>= flip A.readArray 0 +{-# INLINE cast #-} diff --git a/Pinch/Internal/Pinchable.hs b/Pinch/Internal/Pinchable.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Pinchable.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Pinch.Internal.Pinchable +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Provides the core @Pinchable@ typeclass and the @GPinchable@ typeclass used +-- to derive instances automatically. +-- +module Pinch.Internal.Pinchable + ( Pinchable(..) + + , (.=) + , (?=) + , struct + , union + , FieldPair + + , (.:) + , (.:?) + + , GPinchable(..) + , genericPinch + , genericUnpinch + ) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Data.ByteString (ByteString) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Text (Text) +import Data.Typeable ((:~:) (..), eqT) +import Data.Vector (Vector) +import GHC.Generics (Generic, Rep) + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified GHC.Generics as G + +import Pinch.Internal.TType +import Pinch.Internal.Value + +-- | Implementation of 'pinch' based on 'GPinchable'. +genericPinch + :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a)) +genericPinch = gPinch . G.from + +-- | Implementation of 'unpinch' based on 'GPinchable'. +genericUnpinch + :: (Generic a, GPinchable (Rep a)) + => Value (GTag (Rep a)) -> Either String a +genericUnpinch = fmap G.to . gUnpinch + + +-- | GPinchable is used to impelment support for automatically deriving +-- instances of Pinchable via generics. +class IsTType (GTag f) => GPinchable (f :: * -> *) where + -- | 'TType' tag to use for objects of this type. + type GTag f + + -- | Converts a generic representation of a value into a 'Value'. + gPinch :: f a -> Value (GTag f) + + -- | Converts a 'Value' back into the generic representation of the + -- object. + gUnpinch :: Value (GTag f) -> Either String (f a) + + +-- | The Pinchable type class is implemented by types that can be sent or +-- received over the wire as Thrift payloads. +class IsTType (Tag a) => Pinchable a where + -- | 'TType' tag for this type. + -- + -- For most custom types, this will be 'TStruct', 'TUnion', or + -- 'TException'. For enums, it will be 'TEnum'. If the instance + -- automatically derived with use of @Generic@, this is not required + -- because it is automatically determined by use of @Field@ or + -- @Enumeration@. + type Tag a + type Tag a = GTag (Rep a) + + -- | Convert an @a@ into a 'Value'. + -- + -- For structs, 'struct', '.=', and '?=' may be used to construct + -- 'Value' objects tagged with 'TStruct'. + pinch :: a -> Value (Tag a) + + -- | Read a 'Value' back into an @a@. + -- + -- For structs, '.:' and '.:?' may be used to retrieve field values. + unpinch :: Value (Tag a) -> Either String a + + default pinch + :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a)) + pinch = genericPinch + + default unpinch + :: (Generic a, GPinchable (Rep a)) + => Value (GTag (Rep a)) -> Either String a + unpinch = genericUnpinch + + +------------------------------------------------------------------------------ + +-- | A pair of field identifier and maybe a value stored in the field. If the +-- value is absent, the field will be ignored. +type FieldPair = (Int16, Maybe SomeValue) + +-- | Construct a 'FieldPair' from a field identifier and a 'Pinchable' value. +(.=) :: Pinchable a => Int16 -> a -> FieldPair +fid .= value = (fid, Just $ SomeValue (pinch value)) + +-- | Construct a 'FieldPair' from a field identifier and an optional +-- 'Pinchable' value. +(?=) :: Pinchable a => Int16 -> Maybe a -> FieldPair +fid ?= value = (fid, SomeValue . pinch <$> value) + +-- | Construct a 'Value' tagged with a 'TStruct' from the given key-value +-- pairs. Optional fields whose values were omitted will be ignored. +-- +-- > struct [1 .= ("Hello" :: Text), 2 .= (42 :: Int16)] +struct :: [FieldPair] -> Value TStruct +struct = VStruct . foldr go HM.empty + where + go (_, Nothing) m = m + go (k, Just v) m = HM.insert k v m + +-- | Constructs a 'Value' tagged with 'TUnion'. +-- +-- > union 1 ("foo" :: ByteString) +-- +union :: Pinchable a => Int16 -> a -> Value TUnion +union k v = VStruct (HM.singleton k (SomeValue $ pinch v)) + +-- | Given a field ID and a @Value TStruct@, get the value stored in the +-- struct under that field ID. The lookup fails if the field is absent or if +-- it's not the same type as expected by this call's context. +(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Either String a +(VStruct items) .: fieldId = do + someValue <- note ("Field " ++ show fieldId ++ " is absent.") + $ fieldId `HM.lookup` items + (value :: Value (Tag a)) <- + note ("Field " ++ show fieldId ++ " has the incorrect type. " ++ + "Expected '" ++ show (ttype :: TType (Tag a)) ++ "' but " ++ + "got '" ++ showSomeValueTType someValue ++ "'") + $ castValue someValue + unpinch value + where + showSomeValueTType (SomeValue v) = show (valueTType v) + note msg m = case m of + Nothing -> Left msg + Just v -> Right v + +-- | Given a field ID and a @Value TStruct@, get the optional value stored in +-- the struct under the given field ID. The value returned is @Nothing@ if it +-- was absent or the wrong type. The lookup fails only if the value retrieved +-- fails to 'unpinch'. +(.:?) :: forall a. Pinchable a + => Value TStruct -> Int16 -> Either String (Maybe a) +(VStruct items) .:? fieldId = + case value of + Nothing -> return Nothing + Just v -> Just <$> unpinch v + where + value :: Maybe (Value (Tag a)) + value = fieldId `HM.lookup` items >>= castValue + +------------------------------------------------------------------------------ + +-- | Helper to 'unpinch' values by matching TTypes. +checkedUnpinch + :: forall a b. (Pinchable a, IsTType b) + => Value b -> Either String a +checkedUnpinch = case eqT of + Nothing -> const . Left $ + "Type mismatch. Expected " ++ show ttypeA ++ ". Got " ++ show ttypeB + Just (Refl :: Tag a :~: b) -> unpinch + where + ttypeA = ttype :: TType (Tag a) + ttypeB = ttype :: TType b + +-- | Helper to 'pinch' maps. +pinchMap + :: forall k v kval vval m. + ( Pinchable k + , Pinchable v + , kval ~ Value (Tag k) + , vval ~ Value (Tag v) + ) + => ((k -> v -> HashMap kval vval -> HashMap kval vval) + -> HashMap kval vval -> m -> HashMap kval vval) + -- ^ @foldrWithKey@ + -> m -- ^ map that implements @foldrWithKey@ + -> Value TMap +pinchMap folder = VMap . folder go HM.empty + where + go k v = HM.insert (pinch k) (pinch v) + + +instance IsTType a => Pinchable (Value a) where + type Tag (Value a) = a + pinch = id + unpinch = Right + +instance Pinchable ByteString where + type Tag ByteString = TBinary + pinch = VBinary + unpinch (VBinary b) = Right b + unpinch x = Left $ "Failed to read binary. Got " ++ show x + +instance Pinchable Text where + type Tag Text = TBinary + pinch = VBinary . TE.encodeUtf8 + unpinch (VBinary b) = Right . TE.decodeUtf8 $ b + unpinch x = Left $ "Failed to read string. Got " ++ show x + +instance Pinchable Bool where + type Tag Bool = TBool + pinch = VBool + unpinch (VBool x) = Right x + unpinch x = Left $ "Failed to read boolean. Got " ++ show x + +instance Pinchable Int8 where + type Tag Int8 = TByte + pinch = VByte + unpinch (VByte x) = Right x + unpinch x = Left $ "Failed to read byte. Got " ++ show x + +instance Pinchable Double where + type Tag Double = TDouble + pinch = VDouble + unpinch (VDouble x) = Right x + unpinch x = Left $ "Failed to read double. Got " ++ show x + +instance Pinchable Int16 where + type Tag Int16 = TInt16 + pinch = VInt16 + unpinch (VInt16 x) = Right x + unpinch x = Left $ "Failed to read i16. Got " ++ show x + +instance Pinchable Int32 where + type Tag Int32 = TInt32 + pinch = VInt32 + unpinch (VInt32 x) = Right x + unpinch x = Left $ "Failed to read i32. Got " ++ show x + +instance Pinchable Int64 where + type Tag Int64 = TInt64 + pinch = VInt64 + unpinch (VInt64 x) = Right x + unpinch x = Left $ "Failed to read i64. Got " ++ show x + +instance Pinchable a => Pinchable (Vector a) where + type Tag (Vector a) = TList + pinch = VList . V.map pinch + unpinch (VList xs) = V.mapM checkedUnpinch xs + unpinch x = Left $ "Failed to read list. Got " ++ show x + +instance Pinchable a => Pinchable [a] where + type Tag [a] = TList + pinch = VList . V.fromList . map pinch + unpinch (VList xs) = mapM checkedUnpinch $ V.toList xs + unpinch x = Left $ "Failed to read list. Got " ++ show x + +instance + ( Eq k + , Hashable k + , Pinchable k + , Pinchable v + ) => Pinchable (HM.HashMap k v) where + type Tag (HM.HashMap k v) = TMap + pinch = pinchMap HM.foldrWithKey + + unpinch (VMap xs) = + fmap HM.fromList . mapM go $ HM.toList xs + where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v + unpinch x = Left $ "Failed to read map. Got " ++ show x + +instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where + type Tag (M.Map k v) = TMap + pinch = pinchMap M.foldrWithKey + + unpinch (VMap xs) = + fmap M.fromList . mapM go $ HM.toList xs + where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v + unpinch x = Left $ "Failed to read map. Got " ++ show x + +instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where + type Tag (HS.HashSet a) = TSet + pinch = VSet . HS.map pinch + unpinch (VSet xs) = + fmap HS.fromList . mapM checkedUnpinch $ HS.toList xs + unpinch x = Left $ "Failed to read set. Got " ++ show x + +instance (Ord a, Pinchable a) => Pinchable (S.Set a) where + type Tag (S.Set a) = TSet + pinch = VSet . S.foldr (HS.insert . pinch) HS.empty + unpinch (VSet xs) = + fmap S.fromList . mapM checkedUnpinch $ HS.toList xs + unpinch x = Left $ "Failed to read set. Got " ++ show x diff --git a/Pinch/Internal/TType.hs b/Pinch/Internal/TType.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/TType.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +-- | +-- Module : Pinch.Internal.TType +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Defines the different types Thrift supports at the protocol level. +-- +module Pinch.Internal.TType + ( + -- * TType + + TType(..) + , IsTType(..) + , SomeTType(..) + + -- * Tags + + , TBool + , TByte + , TDouble + , TInt16 + , TInt32 + , TEnum + , TInt64 + , TBinary + , TText + , TStruct + , TUnion + , TException + , TMap + , TSet + , TList + ) where + +import Data.Hashable (Hashable (..)) +import Data.Typeable (Typeable) + +-- | > bool +data TBool deriving (Typeable) + +-- | > byte +data TByte deriving (Typeable) + +-- | > double +data TDouble deriving (Typeable) + +-- | > i16 +data TInt16 deriving (Typeable) + +-- | > i32 +data TInt32 deriving (Typeable) + +-- | > enum +type TEnum = TInt32 + +-- | > i64 +data TInt64 deriving (Typeable) + +-- | > binary +data TBinary deriving (Typeable) + +-- | > string +type TText = TBinary + +-- | > struct +data TStruct deriving (Typeable) + +-- | > union +type TUnion = TStruct + +-- | > exception +type TException = TStruct + +-- | > map +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 diff --git a/Pinch/Internal/Value.hs b/Pinch/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Value.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Pinch.Internal.Value +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module defines an intermediate representation for Thrift values and +-- functions to work with the intermediate representation. +module Pinch.Internal.Value + ( Value(..) + , SomeValue(..) + , castValue + , valueTType + ) where + +import Control.DeepSeq (NFData (..)) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable (..)) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Typeable ((:~:) (..), Typeable, cast, eqT) +import Data.Vector (Vector) + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Vector as V + +import Pinch.Internal.TType + + +-- | @Value@ maps directly to serialized representation of Thrift types. It +-- contains about as much information as what gets sent over the wire. +-- @Value@ objects are tagged with different 'TType' values to indicate the +-- type of the value. +-- +-- Typical usage will not involve accessing the constructors for this type. +-- 'Pinch.Pinchable.Pinchable' must be used to construct 'Value' objects or +-- convert them back to original types. +data Value a where + VBool :: !Bool -> Value TBool + VByte :: !Int8 -> Value TByte + VDouble :: !Double -> Value TDouble + VInt16 :: !Int16 -> Value TInt16 + VInt32 :: !Int32 -> Value TInt32 + VInt64 :: !Int64 -> Value TInt64 + VBinary :: !ByteString -> Value TBinary + VStruct :: !(HashMap Int16 SomeValue) -> Value TStruct + + VMap :: forall k v. (IsTType k, IsTType v) + => !(HashMap (Value k) (Value v)) -> Value TMap + VSet :: forall a. IsTType a => !(HashSet (Value a)) -> Value TSet + VList :: forall a. IsTType a => !(Vector (Value a)) -> Value TList + deriving Typeable + +deriving instance Show (Value a) + +instance Eq (Value a) where + VBool a == VBool b = a == b + VByte a == VByte b = a == b + VDouble a == VDouble b = a == b + VInt16 a == VInt16 b = a == b + VInt32 a == VInt32 b = a == b + VInt64 a == VInt64 b = a == b + VBinary a == VBinary b = a == b + VStruct a == VStruct b = a == b + + VMap as == VMap bs = areEqual as bs + VSet as == VSet bs = areEqual as bs + VList as == VList bs = areEqual as bs + + _ == _ = False + +instance NFData (Value a) where + rnf (VBool a) = rnf a + rnf (VByte a) = rnf a + rnf (VDouble a) = rnf a + rnf (VInt16 a) = rnf a + rnf (VInt32 a) = rnf a + rnf (VInt64 a) = rnf a + rnf (VBinary a) = rnf a + rnf (VStruct a) = rnf a + rnf (VMap as) = rnf as + rnf (VSet as) = rnf as + rnf (VList as) = rnf as + +-- | 'SomeValue' holds any value, regardless of type. This may be used when +-- the type of the value is not necessarily known at compile time. Typically, +-- this will be pattern matched on and code that depends on the value's +-- 'TType' will go inside the scope of the match. +data SomeValue where + SomeValue :: (IsTType a) => !(Value a) -> SomeValue + deriving Typeable + +deriving instance Show SomeValue + +instance Eq SomeValue where + SomeValue a == SomeValue b = areEqual a b + +instance NFData SomeValue where + rnf (SomeValue a) = rnf a + +-- | Safely attempt to cast 'SomeValue' into a 'Value'. +castValue :: Typeable a => SomeValue -> Maybe (Value a) +castValue (SomeValue v) = cast v + + +-- | Get the 'TType' of a 'Value'. +valueTType :: IsTType a => Value a -> TType a +valueTType _ = ttype + +-- | Helper to compare two types that are not known to be equal at compile +-- time. +areEqual + :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool +areEqual x y = case eqT of + Nothing -> False + Just (Refl :: a :~: b) -> x == y + + +instance Hashable (Value a) where + hashWithSalt s a = case a of + VBinary x -> s `hashWithSalt` (0 :: Int) `hashWithSalt` x + VBool x -> s `hashWithSalt` (1 :: Int) `hashWithSalt` x + VByte x -> s `hashWithSalt` (2 :: Int) `hashWithSalt` x + VDouble x -> s `hashWithSalt` (3 :: Int) `hashWithSalt` x + VInt16 x -> s `hashWithSalt` (4 :: Int) `hashWithSalt` x + VInt32 x -> s `hashWithSalt` (5 :: Int) `hashWithSalt` x + VInt64 x -> s `hashWithSalt` (6 :: Int) `hashWithSalt` x + + VList xs -> + V.foldr' (flip hashWithSalt) (s `hashWithSalt` (7 :: Int)) xs + VMap xs -> + M.foldrWithKey + (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v) + (s `hashWithSalt` (8 :: Int)) + xs + VSet xs -> + S.foldr (flip hashWithSalt) (s `hashWithSalt` (9 :: Int)) xs + + VStruct fields -> + M.foldrWithKey (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v) + (s `hashWithSalt` (10 :: Int)) + fields + + +instance Hashable SomeValue where + hashWithSalt s (SomeValue v) = hashWithSalt s v diff --git a/Pinch/Protocol.hs b/Pinch/Protocol.hs new file mode 100644 --- /dev/null +++ b/Pinch/Protocol.hs @@ -0,0 +1,42 @@ +{-# 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 Data.ByteString.Builder (Builder) +import Data.Int (Int64) + +import Pinch.Internal.Message (Message) +import Pinch.Internal.TType (IsTType) +import Pinch.Internal.Value (Value) + +-- | Protocols define a specific way to convert values into binary and back. +data Protocol = Protocol + { serializeValue :: forall a. IsTType a => Value a -> (Int64, Builder) + -- ^ Serializes a 'Value' into a ByteString builder. + -- + -- Returns a @Builder@ and the total length of the serialized content. + , serializeMessage :: Message -> (Int64, Builder) + -- ^ Serializes a 'Message' and its payload into a ByteString builder. + -- + -- Returns a @Builder@ and the total length of the serialized content. + + , deserializeValue + :: forall a. IsTType a => ByteString -> Either String (Value a) + -- ^ Reads a 'Value' from a ByteString. + , deserializeMessage :: ByteString -> Either String Message + -- ^ Reads a 'Message' and its payload from a ByteString. + } diff --git a/Pinch/Protocol/Binary.hs b/Pinch/Protocol/Binary.hs new file mode 100644 --- /dev/null +++ b/Pinch/Protocol/Binary.hs @@ -0,0 +1,305 @@ +{-# 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.HashSet (HashSet) +import Data.Int (Int16, Int8) +import Data.Vector (Vector) + +import qualified Data.ByteString as B +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V + +import Pinch.Internal.Builder (Build) +import Pinch.Internal.Message +import Pinch.Internal.Parser (Parser, runParser) +import Pinch.Internal.TType +import Pinch.Internal.Value +import Pinch.Protocol (Protocol (..)) + +import qualified Pinch.Internal.Builder as BB +import qualified Pinch.Internal.Parser as P + + +-- | Provides an implementation of the Thrift Binary Protocol. +binaryProtocol :: Protocol +binaryProtocol = Protocol + { serializeValue = BB.run . binarySerialize + , deserializeValue = binaryDeserialize ttype + , serializeMessage = BB.run . binarySerializeMessage + , deserializeMessage = binaryDeserializeMessage + } + +------------------------------------------------------------------------------ + +binarySerializeMessage :: Message -> Build +binarySerializeMessage msg = do + binarySerialize . VBinary . TE.encodeUtf8 $ messageName msg + BB.int8 $ messageCode (messageType msg) + BB.int32 $ messageId msg + binarySerialize (messagePayload msg) + + +binaryDeserializeMessage :: ByteString -> Either String Message +binaryDeserializeMessage = runParser binaryMessageParser + +binaryMessageParser :: Parser Message +binaryMessageParser = do + size <- P.int32 + if size < 0 + then parseStrict size + else parseNonStrict size + where + -- versionAndType:4 name~4 seqid:4 payload + -- versionAndType = version:2 0x00 type:1 + parseStrict versionAndType = do + unless (version == 1) $ + fail $ "Unsupported version: " ++ show version + Message + <$> TE.decodeUtf8 <$> (P.int32 >>= P.take . fromIntegral) + <*> typ + <*> P.int32 + <*> binaryParser ttype + where + version = (0x7fff0000 .&. versionAndType) `shiftR` 16 + + code = fromIntegral $ 0x00ff .&. versionAndType + typ = case fromMessageCode code of + Nothing -> fail $ "Unknown message type: " ++ show code + Just t -> return t + + -- name~4 type:1 seqid:4 payload + parseNonStrict nameLength = + Message + <$> TE.decodeUtf8 <$> P.take (fromIntegral nameLength) + <*> parseMessageType + <*> P.int32 + <*> binaryParser ttype + + +parseMessageType :: Parser MessageType +parseMessageType = P.int8 >>= \code -> case fromMessageCode code of + Nothing -> fail $ "Unknown message type: " ++ show code + Just t -> return t + +------------------------------------------------------------------------------ + +binaryDeserialize :: TType a -> ByteString -> Either String (Value a) +binaryDeserialize t = runParser (binaryParser t) + +binaryParser :: TType a -> Parser (Value a) +binaryParser typ = case typ of + TBool -> parseBool + TByte -> parseByte + TDouble -> parseDouble + TInt16 -> parseInt16 + TInt32 -> parseInt32 + TInt64 -> parseInt64 + TBinary -> parseBinary + TStruct -> parseStruct + TMap -> parseMap + TSet -> parseSet + TList -> parseList + +getTType :: Int8 -> Parser SomeTType +getTType code = + maybe (fail $ "Unknown TType: " ++ show code) return $ fromTypeCode code + +parseTType :: Parser SomeTType +parseTType = P.int8 >>= getTType + +parseBool :: Parser (Value TBool) +parseBool = VBool . (== 1) <$> P.int8 + +parseByte :: Parser (Value TByte) +parseByte = VByte <$> P.int8 + +parseDouble :: Parser (Value TDouble) +parseDouble = VDouble <$> P.double + +parseInt16 :: Parser (Value TInt16) +parseInt16 = VInt16 <$> P.int16 + +parseInt32 :: Parser (Value TInt32) +parseInt32 = VInt32 <$> P.int32 + +parseInt64 :: Parser (Value TInt64) +parseInt64 = VInt64 <$> P.int64 + +parseBinary :: Parser (Value TBinary) +parseBinary = VBinary <$> (P.int32 >>= P.take . fromIntegral) + + +parseMap :: Parser (Value TMap) +parseMap = do + ktype' <- parseTType + vtype' <- parseTType + count <- P.int32 + + case (ktype', vtype') of + (SomeTType ktype, SomeTType vtype) -> do + pairs <- replicateM (fromIntegral count) $ + (,) <$> binaryParser ktype + <*> binaryParser vtype + return $ VMap (M.fromList pairs) + + +parseSet :: Parser (Value TSet) +parseSet = do + vtype' <- parseTType + count <- P.int32 + + case vtype' of + SomeTType vtype -> do + items <- replicateM (fromIntegral count) (binaryParser vtype) + return $ VSet (S.fromList items) + + +parseList :: Parser (Value TList) +parseList = do + vtype' <- parseTType + count <- P.int32 + + case vtype' of + SomeTType vtype -> + VList <$> V.replicateM (fromIntegral count) (binaryParser vtype) + + +parseStruct :: Parser (Value TStruct) +parseStruct = P.int8 >>= loop M.empty + where + loop :: HashMap Int16 SomeValue -> Int8 -> Parser (Value TStruct) + loop fields 0 = return $ VStruct fields + loop fields code = do + vtype' <- getTType code + fieldId <- P.int16 + case vtype' of + SomeTType vtype -> do + value <- SomeValue <$> binaryParser vtype + loop (M.insert fieldId value fields) =<< P.int8 + + +------------------------------------------------------------------------------ + +binarySerialize :: Value a -> Build +binarySerialize v0 = case v0 of + VBinary x -> do + BB.int32 . fromIntegral . B.length $ x + BB.byteString x + VBool x -> BB.int8 $ if x then 1 else 0 + VByte x -> BB.int8 x + VDouble x -> BB.double x + VInt16 x -> BB.int16 x + VInt32 x -> BB.int32 x + VInt64 x -> BB.int64 x + VStruct xs -> serializeStruct xs + VList xs -> serializeList ttype xs + VMap xs -> serializeMap ttype ttype xs + VSet xs -> serializeSet ttype xs + + +serializeStruct :: HashMap Int16 SomeValue -> Build +serializeStruct fields = do + forM_ (M.toList fields) $ \(fieldId, SomeValue fieldValue) -> + writeField fieldId ttype fieldValue + BB.int8 0 + where + writeField :: Int16 -> TType a -> Value a -> Build + writeField fieldId fieldType fieldValue = do + BB.int8 (toTypeCode fieldType) + BB.int16 fieldId + binarySerialize fieldValue + + +serializeList :: TType a -> Vector (Value a) -> Build +serializeList vtype xs = do + BB.int8 $ toTypeCode vtype + BB.int32 $ fromIntegral (V.length xs) + mapM_ binarySerialize (V.toList xs) + + +serializeMap :: TType k -> TType v -> HashMap (Value k) (Value v) -> Build +serializeMap kt vt xs = do + BB.int8 $ toTypeCode kt + BB.int8 $ toTypeCode vt + BB.int32 $ fromIntegral (M.size xs) + forM_ (M.toList xs) $ \(k, v) -> do + binarySerialize k + binarySerialize v + + +serializeSet :: TType a -> HashSet (Value a) -> Build +serializeSet vtype xs = do + BB.int8 $ toTypeCode vtype + BB.int32 $ fromIntegral (S.size xs) + mapM_ binarySerialize (S.toList xs) + + +------------------------------------------------------------------------------ + + +messageCode :: MessageType -> Int8 +messageCode Call = 1 +messageCode Reply = 2 +messageCode Exception = 3 +messageCode Oneway = 4 + + +fromMessageCode :: Int8 -> Maybe MessageType +fromMessageCode 1 = Just Call +fromMessageCode 2 = Just Reply +fromMessageCode 3 = Just Exception +fromMessageCode 4 = Just Oneway +fromMessageCode _ = Nothing + + +-- | Map a TType to its type code. +toTypeCode :: TType a -> Int8 +toTypeCode TBool = 2 +toTypeCode TByte = 3 +toTypeCode TDouble = 4 +toTypeCode TInt16 = 6 +toTypeCode TInt32 = 8 +toTypeCode TInt64 = 10 +toTypeCode TBinary = 11 +toTypeCode TStruct = 12 +toTypeCode TMap = 13 +toTypeCode TSet = 14 +toTypeCode TList = 15 + + +-- | Map a type code to the corresponding TType. +fromTypeCode :: Int8 -> Maybe SomeTType +fromTypeCode 2 = Just $ SomeTType TBool +fromTypeCode 3 = Just $ SomeTType TByte +fromTypeCode 4 = Just $ SomeTType TDouble +fromTypeCode 6 = Just $ SomeTType TInt16 +fromTypeCode 8 = Just $ SomeTType TInt32 +fromTypeCode 10 = Just $ SomeTType TInt64 +fromTypeCode 11 = Just $ SomeTType TBinary +fromTypeCode 12 = Just $ SomeTType TStruct +fromTypeCode 13 = Just $ SomeTType TMap +fromTypeCode 14 = Just $ SomeTType TSet +fromTypeCode 15 = Just $ SomeTType TList +fromTypeCode _ = Nothing diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +`pinch` aims to provide an alternative implementation of Apache Thrift for +Haskell. The `pinch` library itself acts only as a serialization library. Types +specify their Thrift encoding by defining instances of the `Pinchable` +typeclass, which may be done by hand or automatically with the use of Generics. +Check the documentation and examples for more information. + +Haddock documentation for this package is avilable on [Hackage] and [here]. + + [Hackage]: http://hackage.haskell.org/package/pinch + [here]: http://abhinavg.net/pinch/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main (main) where + +import Control.DeepSeq (NFData) +import Criterion +import Criterion.Main (defaultMain) +import Data.ByteString (ByteString) +import Data.Int +import Data.Text (Text) +import GHC.Generics (Generic) +import Pinch ((.:), (.=)) + +import qualified Data.Text as T +import qualified Pinch as P +import qualified Test.QuickCheck as QC + +data A = A + { aName :: Text + , aBirthDay :: Int64 + , aPhone :: Text + , aSiblings :: Int32 + , aSpouse :: Bool + , aMoney :: Double + } deriving (Show, Ord, Eq, Generic) + +instance NFData A + +instance QC.Arbitrary A where + arbitrary = A + <$> (T.pack <$> QC.arbitrary) + <*> QC.arbitrary + <*> (T.pack <$> QC.arbitrary) + <*> QC.arbitrary + <*> QC.arbitrary + <*> QC.arbitrary + + +instance P.Pinchable A where + type Tag A = P.TStruct + + pinch A{..} = P.struct + [ 1 .= aName + , 2 .= aBirthDay + , 3 .= aPhone + , 4 .= aSiblings + , 5 .= aSpouse + , 6 .= aMoney + ] + + unpinch m = A + <$> m .: 1 + <*> m .: 2 + <*> m .: 3 + <*> m .: 4 + <*> m .: 5 + <*> m .: 6 + + +data A2 = A2 + { a2Name :: P.Field 1 Text + , a2BirthDay :: P.Field 2 Int64 + , a2Phone :: P.Field 3 Text + , a2Siblings :: P.Field 4 Int32 + , a2Spouse :: P.Field 5 Bool + , a2Money :: P.Field 6 Double + } deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable A2 +instance NFData A2 + +instance QC.Arbitrary A2 where + arbitrary = A2 + <$> (P.putField . T.pack <$> QC.arbitrary) + <*> (P.putField <$> QC.arbitrary) + <*> (P.putField . T.pack <$> QC.arbitrary) + <*> (P.putField <$> QC.arbitrary) + <*> (P.putField <$> QC.arbitrary) + <*> (P.putField <$> QC.arbitrary) + + +main :: IO () +main = defaultMain + [ bgroup "Pinch" + [ env (generate :: IO A) $ \a -> + bench "encode" $ whnf (P.encode P.binaryProtocol) a + , env (P.encode P.binaryProtocol <$> (generate :: IO A)) $ \bs -> + bench "decode" $ + whnf (P.decode P.binaryProtocol :: ByteString -> Either String A) bs + ] + , bgroup "Pinch Generic" + [ env (generate :: IO A2) $ \a -> + bench "encode" $ whnf (P.encode P.binaryProtocol) a + , env (P.encode P.binaryProtocol <$> (generate :: IO A2)) $ \bs -> + bench "decode" $ + whnf (P.decode P.binaryProtocol :: ByteString -> Either String A2) bs + ] + ] + where + generate :: QC.Arbitrary a => IO a + generate = QC.generate QC.arbitrary diff --git a/examples/keyvalue/Client.hs b/examples/keyvalue/Client.hs new file mode 100644 --- /dev/null +++ b/examples/keyvalue/Client.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main (main) where + +import Control.Monad +import Control.Monad.Catch (Exception, throwM) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Char (isSpace) +import Data.Function (fix) +import Data.Maybe +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP +import qualified Pinch as P + +import Types + + +data ClientError + = HTTPError HTTP.Status ByteString + | ThriftProtocolError String + deriving (Show, Eq, Typeable) + +instance Exception ClientError + + +keyValueClient :: String -> HTTP.Manager -> KeyValue IO +keyValueClient url manager = KeyValue + { getValue = mkRequest "getValue" + , setValue = mkRequest "setValue" + } + where + baseRequest = fromMaybe (error "Invalid URL") (HTTP.parseUrl url) + + encode = P.encodeMessage P.binaryProtocol + decode = P.decodeMessage P.binaryProtocol + + mkRequest :: forall req res. + ( P.Pinchable req, P.Tag req ~ P.TStruct + , P.Pinchable res, P.Tag res ~ P.TStruct + ) => Text -> req -> IO res + mkRequest name call = do + res <- HTTP.httpLbs req manager + + let status = HTTP.responseStatus res + body = toStrict (HTTP.responseBody res) + + unless (HTTP.statusIsSuccessful status) $ + throwM (HTTPError status body) + + case decode body >>= P.getMessageBody of + Left err -> throwM (ThriftProtocolError err) + Right reply -> return reply + where + message = P.mkMessage name P.Call 0 call + req = baseRequest + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyBS $ encode message + } + + +main :: IO () +main = do + client <- keyValueClient "http://localhost:8080" + <$> HTTP.newManager HTTP.defaultManagerSettings + + fix $ \loop -> do + line <- TIO.getLine + case T.split isSpace line of + ["quit"] -> return () + + ["get", key] -> do + res <- getValue client (GetValueRequest (P.putField key)) + case res of + GetValueSuccess value -> print value + GetValueDoesNotExist _ -> putStrLn "No matching value." + loop + + ["set", key, value] -> do + let v = ValueBin (P.putField (encodeUtf8 value)) + _ <- setValue client $ + SetValueRequest (P.putField key) (P.putField v) + loop + + _ -> putStrLn "Invalid command" >> loop diff --git a/examples/keyvalue/Server.hs b/examples/keyvalue/Server.hs new file mode 100644 --- /dev/null +++ b/examples/keyvalue/Server.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Main (main) where + +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Lazy.Char8 (pack) +import Data.IORef (IORef) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Network.Wai.Handler.Warp (run) + +import qualified Data.IORef as IORef +import qualified Data.Map.Strict as Map +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as HTTP +import qualified Pinch as P + +import Types hiding (KeyValue (..)) + +type ValueStore = IORef (Map Text Value) + +newValueStore :: IO ValueStore +newValueStore = IORef.newIORef Map.empty + +getValue :: ValueStore -> GetValueRequest -> IO GetValueResponse +getValue store req = do + m <- IORef.readIORef store + return $! case key `Map.lookup` m of + Nothing -> + GetValueDoesNotExist . P.putField $ + KeyDoesNotExist (P.putField Nothing) + Just value -> + GetValueSuccess (P.putField value) + where + GetValueRequest{getValueKey = P.Field key} = req + +setValue :: ValueStore -> SetValueRequest -> IO SetValueResponse +setValue store req = do + IORef.atomicModifyIORef' store (\m -> (Map.insert key value m, ())) + return $ SetValueSuccess P.Void + where + SetValueRequest + { setValueKey = P.Field key + , setValueValue = P.Field value + } = req + +app :: ValueStore -> HTTP.Application +app store request respond = do + requestBody <- toStrict <$> HTTP.strictRequestBody request + either handleError handleMessage $ decode requestBody + where + encode = P.encodeMessage P.binaryProtocol + decode = P.decodeMessage P.binaryProtocol + + respondSuccess = respond . HTTP.responseLBS HTTP.status200 [] . fromStrict + handleError err = respond $ HTTP.responseLBS HTTP.status500 [] (pack err) + + handle + :: forall req res. + ( P.Pinchable req, P.Tag req ~ P.TStruct + , P.Pinchable res, P.Tag res ~ P.TStruct + ) + => (ValueStore -> req -> IO res) -> P.Message + -> IO HTTP.ResponseReceived + handle f msg = case P.getMessageBody msg of + Left err -> handleError err + Right (req :: req) -> do + res <- f store req + respondSuccess . encode $ + P.mkMessage messageName P.Reply messageId res + where + messageName = P.messageName msg + messageId = P.messageId msg + + handleMessage m = case P.messageName m of + "getValue" -> handle getValue m + "setValue" -> handle setValue m + name -> handleError $ "Unknown method: " ++ show name + -- TODO use TApplicationException format for this + +main :: IO () +main = newValueStore >>= \store -> run 8080 (app store) diff --git a/examples/keyvalue/Setup.hs b/examples/keyvalue/Setup.hs new file mode 100644 --- /dev/null +++ b/examples/keyvalue/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/keyvalue/Types.hs b/examples/keyvalue/Types.hs new file mode 100644 --- /dev/null +++ b/examples/keyvalue/Types.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +module Types + ( Value(..) + , KeyDoesNotExist(..) + + , SetValueRequest(..) + , SetValueResponse(..) + + , GetValueRequest(..) + , GetValueResponse(..) + + , KeyValue(..) + ) where + +import Data.ByteString (ByteString) +import Data.Set (Set) +import Data.Text (Text) +import GHC.Generics (Generic) + +import qualified Pinch as P + +data Value + = ValueBin (P.Field 1 ByteString) + | ValueBinSet (P.Field 2 (Set ByteString)) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable Value + + +data KeyDoesNotExist = KeyDoesNotExist (P.Field 1 (Maybe Text)) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable KeyDoesNotExist + + +data SetValueRequest = SetValueRequest + { setValueKey :: P.Field 1 Text + , setValueValue :: P.Field 2 Value + } deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable SetValueRequest + + +data SetValueResponse = SetValueSuccess P.Void + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable SetValueResponse + + +data GetValueRequest = GetValueRequest + { getValueKey :: P.Field 1 Text + } deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable GetValueRequest + + +data GetValueResponse + = GetValueSuccess (P.Field 0 Value) + | GetValueDoesNotExist (P.Field 1 KeyDoesNotExist) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable GetValueResponse + +data KeyValue m = KeyValue + { getValue :: GetValueRequest -> m GetValueResponse + , setValue :: SetValueRequest -> m SetValueResponse + } diff --git a/examples/keyvalue/keyvalue.cabal b/examples/keyvalue/keyvalue.cabal new file mode 100644 --- /dev/null +++ b/examples/keyvalue/keyvalue.cabal @@ -0,0 +1,36 @@ +name : keyvalue +version : 0.1.0.0 +author : Abhinav Gupta +maintainer : mail@abhinavg.net +build-type : Simple +cabal-version : >=1.10 + +executable keyvalue-server + main-is : Server.hs + other-modules : Types + ghc-options : -Wall -threaded + build-depends : base + , bytestring + , containers + , http-types >= 0.8 && < 0.9 + , text + , wai >= 3.0 && < 4.0 + , warp >= 3.0 && < 4.0 + + , pinch + default-language : Haskell2010 + +executable keyvalue-client + main-is : Client.hs + other-modules : Types + ghc-options : -Wall -threaded + build-depends : base + , bytestring + , containers + , exceptions + , http-client >= 0.4 && < 0.5 + , http-types >= 0.8 && < 0.9 + , text + + , pinch + default-language : Haskell2010 diff --git a/examples/keyvalue/keyvalue.thrift b/examples/keyvalue/keyvalue.thrift new file mode 100644 --- /dev/null +++ b/examples/keyvalue/keyvalue.thrift @@ -0,0 +1,15 @@ +exception KeyDoesNotExist { + 1: optional string message +} + +union Value { + 1: binary bin + 2: set binSet +} + +service KeyValue { + void setValue(1: string key, 2: Value value) + + Value getValue(1: string key) + throws (1: KeyDoesNotExist doesNotExist) +} diff --git a/pinch.cabal b/pinch.cabal new file mode 100644 --- /dev/null +++ b/pinch.cabal @@ -0,0 +1,107 @@ +name: pinch +version: 0.1.0.0 +synopsis: An alternative implementation of Thrift for Haskell. +homepage: https://github.com/abhinav/pinch +license: BSD3 +license-file: LICENSE +author: Abhinav Gupta +maintainer: mail@abhinavg.net +category: Development +build-type: Simple +cabal-version: >=1.10 +description: + This library provides machinery for types to specify how they can be + serialized and deserialized into/from Thrift payloads. It makes no + assumptions on how these payloads are sent or received and performs no + code generation. Types may specify how to be serialized and deserialized + by defining instances of the @Pinchable@ typeclass by hand, or with + automatically derived instances by using generics. Check the documentation + in the "Pinch" module for more information. + . + /What is Thrift?/ Apache Thrift provides an interface description + language, a set of communication protocols, and a code generator and + libraries for various programming languages to interact with the generated + code. Pinch aims to provide an alternative implementation of Thrift for + Haskell. +extra-source-files: + README.md + CHANGES.md + examples/keyvalue/*.hs + examples/keyvalue/*.cabal + examples/keyvalue/*.thrift + + +library + exposed-modules : Pinch.Internal.Generic + , Pinch.Internal.Builder + , Pinch.Internal.Message + , Pinch.Internal.Parser + , Pinch.Internal.Pinchable + , Pinch.Internal.TType + , Pinch.Internal.Value + , Pinch.Protocol + , Pinch.Protocol.Binary + , Pinch + ghc-options : -Wall + build-depends : base >= 4.7 && < 4.9 + + , array >= 0.5 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , deepseq >= 1.3 && < 1.5 + , hashable >= 1.2 && < 1.3 + , text >= 1.2 && < 1.3 + , unordered-containers >= 0.2 && < 0.3 + , vector >= 0.10 && < 0.11 + default-language : Haskell2010 + + +test-suite pinch-spec + type : exitcode-stdio-1.0 + hs-source-dirs : tests + ghc-options : -Wall + main-is : Spec.hs + other-modules : Pinch.Arbitrary + , Pinch.Expectations + , Pinch.Protocol.BinarySpec + , Pinch.Internal.BuilderSpec + , Pinch.Internal.GenericSpec + , Pinch.Internal.ParserSpec + , Pinch.Internal.PinchableSpec + , Pinch.Internal.TTypeSpec + , Pinch.Internal.Util + , Pinch.Internal.ValueSpec + build-depends : base + + , bytestring + , containers + , hspec >= 2.0 + , hspec-discover >= 2.1 + , QuickCheck >= 2.5 + , text + , unordered-containers + , vector + + , pinch + default-language : Haskell2010 + + +benchmark pinch-bench + type : exitcode-stdio-1.0 + main-is : Bench.hs + hs-source-dirs : bench + ghc-options : -O2 -Wall + build-depends : base + , bytestring + , criterion >= 1.0 + , deepseq + , QuickCheck >= 2.8 + , text + + , pinch + default-language : Haskell2010 + + +source-repository head + type : git + location : git://github.com/abhinav/pinch.git diff --git a/tests/Pinch/Arbitrary.hs b/tests/Pinch/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Arbitrary.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Pinch.Arbitrary + ( SomeByteString(..) + ) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Test.QuickCheck + +import qualified Data.ByteString as B +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Text as Tx +import qualified Data.Vector as V + +import qualified Pinch.Internal.Message as TM +import qualified Pinch.Internal.TType as T +import qualified Pinch.Internal.Value as V + +#if !MIN_VERSION_QuickCheck(2, 8, 0) +scale :: (Int -> Int) -> Gen a -> Gen a +scale f g = sized (\n -> resize (f n) g) +#endif + +halfSize :: Gen a -> Gen a +halfSize = scale (\n -> truncate (fromIntegral n / 2 :: Double)) + +newtype SomeByteString = SomeByteString + { getSomeByteString :: ByteString } + deriving (Show, Eq) + +instance Arbitrary SomeByteString where + arbitrary = SomeByteString . B.pack <$> arbitrary + + shrink (SomeByteString bs) + | B.null bs = [] + | otherwise = + SomeByteString . B.pack <$> shrink (B.unpack bs) + +newtype SomeText = SomeText { getSomeText :: Text } + +instance Arbitrary SomeText where + arbitrary = SomeText . Tx.pack <$> arbitrary + shrink = map (SomeText . Tx.pack) . shrink . Tx.unpack . getSomeText + + +instance Arbitrary T.SomeTType where + arbitrary = elements + [ T.SomeTType T.TBool + , T.SomeTType T.TByte + , T.SomeTType T.TDouble + , T.SomeTType T.TInt16 + , T.SomeTType T.TInt32 + , T.SomeTType T.TInt64 + , T.SomeTType T.TBinary + , T.SomeTType T.TStruct + , T.SomeTType T.TMap + , T.SomeTType T.TSet + , T.SomeTType T.TList + ] + shrink _ = [] + +instance Arbitrary V.SomeValue where + arbitrary = arbitrary >>= \(T.SomeTType t) -> genValue t + where + genValue + :: forall a. T.IsTType a + => T.TType a -> Gen V.SomeValue + genValue _ = V.SomeValue <$> (arbitrary :: Gen (V.Value a)) + + shrink (V.SomeValue v) = V.SomeValue <$> shrink v + + +instance T.IsTType a => Arbitrary (V.Value a) where + arbitrary = case T.ttype :: T.TType a of + T.TBool -> V.VBool <$> arbitrary + T.TByte -> V.VByte <$> arbitrary + T.TDouble -> V.VDouble <$> arbitrary + T.TInt16 -> V.VInt16 <$> arbitrary + T.TInt32 -> V.VInt32 <$> arbitrary + T.TInt64 -> V.VInt64 <$> arbitrary + T.TBinary -> V.VBinary . getSomeByteString <$> arbitrary + T.TStruct -> genStruct + T.TMap -> do + ktype <- arbitrary + vtype <- arbitrary + case (ktype, vtype) of + (T.SomeTType kt, T.SomeTType vt) -> + V.VMap <$> genMap kt vt + T.TSet -> arbitrary >>= \(T.SomeTType t) -> V.VSet <$> genSet t + T.TList -> arbitrary >>= \(T.SomeTType t) -> V.VList <$> genVec t + where + genStruct = halfSize $ V.VStruct . M.fromList <$> listOf genField + where + genField = (,) <$> (getPositive <$> arbitrary) + <*> arbitrary + + genMap :: (T.IsTType k, T.IsTType v) + => T.TType k -> T.TType v + -> Gen (M.HashMap (V.Value k) (V.Value v)) + genMap _ _ = M.fromList <$> halfSize arbitrary + + genSet :: T.IsTType x => T.TType x -> Gen (S.HashSet (V.Value x)) + genSet _ = S.fromList <$> halfSize arbitrary + + genVec :: T.IsTType x => T.TType x -> Gen (V.Vector (V.Value x)) + genVec _ = V.fromList <$> halfSize arbitrary + + shrink = case T.ttype :: T.TType a of + T.TByte -> \(V.VByte x) -> V.VByte <$> shrink x + T.TDouble -> \(V.VDouble x) -> V.VDouble <$> shrink x + T.TInt16 -> \(V.VInt16 x) -> V.VInt16 <$> shrink x + T.TInt32 -> \(V.VInt32 x) -> V.VInt32 <$> shrink x + T.TInt64 -> \(V.VInt64 x) -> V.VInt64 <$> shrink x + T.TBinary -> shrinkBinary + T.TStruct -> + \(V.VStruct xs) -> V.VStruct . M.fromList <$> shrink (M.toList xs) + T.TMap -> + \(V.VMap xs) -> V.VMap . M.fromList <$> shrink (M.toList xs) + T.TSet -> + \(V.VSet xs) -> V.VSet . S.fromList <$> shrink (S.toList xs) + T.TList -> + \(V.VList xs) -> V.VList . V.fromList <$> shrink (V.toList xs) + _ -> const [] + where + shrinkBinary :: V.Value T.TBinary -> [V.Value T.TBinary] + shrinkBinary (V.VBinary bs) + | B.null bs = [] + | otherwise = V.VBinary . B.pack <$> shrink (B.unpack bs) + + +instance Arbitrary TM.MessageType where + arbitrary = elements + [ TM.Call + , TM.Reply + , TM.Exception + , TM.Oneway + ] + shrink _ = [] + + +instance Arbitrary TM.Message where + arbitrary = + TM.Message + <$> (getSomeText <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + + shrink (TM.Message name typ mid body) = + [ TM.Message name' typ' mid' body' + | (SomeText name', typ', mid', body') <- + shrink ((SomeText name), typ, mid, body) + ] diff --git a/tests/Pinch/Expectations.hs b/tests/Pinch/Expectations.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Expectations.hs @@ -0,0 +1,17 @@ +module Pinch.Expectations + ( leftShouldContain + , leftShouldContainAll + ) where + + +import Test.Hspec + +-- | Expectation +leftShouldContain :: Show a => Either String a -> String -> Expectation +leftShouldContain (Right a) _ = + expectationFailure $ "Expected failure but got: " ++ show a +leftShouldContain (Left msg) x = msg `shouldContain` x +infix 1 `leftShouldContain` + +leftShouldContainAll :: Show a => Either String a -> [String] -> Expectation +leftShouldContainAll e = mapM_ (leftShouldContain e) diff --git a/tests/Pinch/Internal/BuilderSpec.hs b/tests/Pinch/Internal/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/BuilderSpec.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +module Pinch.Internal.BuilderSpec (spec) where + +import Control.Arrow (second) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Int (Int64) +import Data.Word (Word8) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import qualified Data.ByteString as B + +import Pinch.Arbitrary +import Pinch.Internal.Builder (Build) + +import qualified Pinch.Internal.Builder as BB + +run :: Build -> (Int64, ByteString) +run = second (toStrict . toLazyByteString) . BB.run + + +encodeCases + :: (a -> Build) -> [([Word8], a)] -> Expectation +encodeCases encode = mapM_ . uncurry $ \bytes a -> do + let (size, encoded) = run (encode a) + expected = B.pack bytes + encoded `shouldBe` expected + fromIntegral size `shouldBe` B.length expected + + +spec :: Spec +spec = describe "Builder" $ do + + it "can encode 8-bit integers" $ + encodeCases BB.int8 + [ ([0x01], 1) + , ([0x05], 5) + , ([0x7f], 127) + , ([0xff], -1) + , ([0x80], -128) + ] + + it "can encode 16-bit integers" $ + encodeCases BB.int16 + [ ([0x00, 0x01], 1) + , ([0x00, 0xff], 255) + , ([0x01, 0x00], 256) + , ([0x01, 0x01], 257) + , ([0x7f, 0xff], 32767) + , ([0xff, 0xff], -1) + , ([0xff, 0xfe], -2) + , ([0xff, 0x00], -256) + , ([0xff, 0x01], -255) + , ([0x80, 0x00], -32768) + ] + + it "can encode 32-bit integers" $ + encodeCases BB.int32 + [ ([0x00, 0x00, 0x00, 0x01], 1) + , ([0x00, 0x00, 0x00, 0xff], 255) + , ([0x00, 0x00, 0xff, 0xff], 65535) + , ([0x00, 0xff, 0xff, 0xff], 16777215) + , ([0x7f, 0xff, 0xff, 0xff], 2147483647) + , ([0xff, 0xff, 0xff, 0xff], -1) + , ([0xff, 0xff, 0xff, 0x00], -256) + , ([0xff, 0xff, 0x00, 0x00], -65536) + , ([0xff, 0x00, 0x00, 0x00], -16777216) + , ([0x80, 0x00, 0x00, 0x00], -2147483648) + ] + + it "can encode 64-bit integers" $ + encodeCases BB.int64 + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1) + , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295) + , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775) + , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 281474976710655) + , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 72057594037927935) + , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 9223372036854775807) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1) + , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], -4294967296) + , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], -1099511627776) + , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -281474976710656) + , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -72057594037927936) + , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808) + ] + + it "can encode doubles" $ + encodeCases BB.double + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001) + , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], 1.1) + , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], -1.1) + , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], 3.141592653589793) + , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001) + ] + + prop "can encode bytestrings" $ \(SomeByteString bs) -> + run (BB.byteString bs) === (fromIntegral $ B.length bs, bs) + + it "can join multiple operations using (>>)" $ + encodeCases (\(a, b) -> BB.int16 a >> BB.byteString b) + [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64] + , (4660, "abcd") + ) + , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f] + , (0, "hello") + ) + ] + + it "can join multiple operations using (>>=)" $ + encodeCases (\(a, b) -> BB.int16 a >>= \() -> BB.byteString b) + [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64] + , (4660, "abcd") + ) + , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f] + , (0, "hello") + ) + ] diff --git a/tests/Pinch/Internal/GenericSpec.hs b/tests/Pinch/Internal/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/GenericSpec.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Pinch.Internal.GenericSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Int (Int32, Int8) +import Data.Set (Set) +import Data.Text (Text) +import GHC.Generics (Generic) +import GHC.TypeLits () +import Test.Hspec +import Test.Hspec.QuickCheck + +import qualified Data.Set as S + +import Pinch.Expectations +import Pinch.Internal.Util + +import qualified Pinch.Internal.Generic as G +import qualified Pinch.Internal.Pinchable as P +import qualified Pinch.Internal.TType as T +import qualified Pinch.Internal.Value as V + + +data AnEnum + = EnumA (G.Enumeration 1) + | EnumB (G.Enumeration 2) + | EnumC (G.Enumeration 3) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable AnEnum + + +enumSpec :: Spec +enumSpec = describe "Enum" $ do + + it "can pinch and unpinch" $ do + P.pinch (EnumA G.enum) `shouldBe` vi32 1 + P.pinch (EnumB G.enum) `shouldBe` vi32 2 + P.pinch (EnumC G.enum) `shouldBe` vi32 3 + + P.unpinch (vi32 1) `shouldBe` Right (EnumA G.enum) + P.unpinch (vi32 2) `shouldBe` Right (EnumB G.enum) + P.unpinch (vi32 3) `shouldBe` Right (EnumC G.enum) + + it "reject invalid values" $ + (P.unpinch :: V.Value T.TInt32 -> Either String AnEnum) + (vi32 4) `leftShouldContain` "Couldn't match enum value 4" + +data AUnion + = UnionDouble (G.Field 1 Double) + | UnionByte (G.Field 2 Int8) + | UnionSet (G.Field 5 (Set AnEnum)) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable AUnion + + +data UnionWithVoid + = UnionVoidBefore (G.Field 1 Int8) + | UnionVoid G.Void + | UnionVoidAfter (G.Field 2 Text) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable UnionWithVoid + +unionSpec :: Spec +unionSpec = describe "Union" $ do + + prop "can pinch (1)" $ \dub -> + P.pinch (UnionDouble (G.putField dub)) `shouldBe` + vstruct [(1, vdub_ dub)] + + prop "can pinch (2)" $ \byt -> + P.pinch (UnionByte (G.putField byt)) `shouldBe` + vstruct [(2, vbyt_ byt)] + + it "can pinch (3)" $ + P.pinch + (UnionSet (G.putField $ S.fromList [EnumA G.enum, EnumB G.enum])) + `shouldBe` + vstruct + [(5, vset_ [vi32 1, vi32 2])] + + it "can pinch (4)" $ do + P.pinch (UnionVoidBefore (G.putField 42)) + `shouldBe` vstruct [(1, vbyt_ 42)] + + P.pinch (UnionVoidAfter (G.putField "foo")) + `shouldBe` vstruct [(2, vbin_ "foo")] + + P.pinch (UnionVoid G.Void) `shouldBe` vstruct [] + + it "can unpinch" $ do + P.unpinch (vstruct [(1, vdub_ 12.34)]) + `shouldBe` Right (UnionDouble $ G.putField 12.34) + + P.unpinch (vstruct [(2, vbyt_ 123)]) + `shouldBe` Right (UnionByte $ G.putField 123) + + P.unpinch + (vstruct [(5, vset_ [vi32 1, vi32 2])]) + `shouldBe` Right + (UnionSet . G.putField . S.fromList + $ [EnumA G.enum, EnumB G.enum]) + + P.unpinch (vstruct [(1, vbyt_ 42)]) + `shouldBe` Right (UnionVoidBefore $ G.putField 42) + + P.unpinch (vstruct [(2, vbin_ "foo")]) + `shouldBe` Right (UnionVoidAfter $ G.putField "foo") + + P.unpinch (vstruct []) `shouldBe` Right (UnionVoid G.Void) + + it "reject invalid types" $ do + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(1, vi32_ 1)]) + `leftShouldContain` "is absent" + + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(2, vbool_ True)]) + `leftShouldContain` "is absent" + + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(5, vlist_ [vi32 1, vi32 2])]) + `leftShouldContain` "has the incorrect type" + + it "reject invalid IDs" $ + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(3, vdub_ 1.0)]) + `leftShouldContain` "is absent" + + +data AStruct = AStruct (G.Field 1 ByteString) (G.Field 5 (Maybe Int32)) + deriving (Show, Ord, Eq, Generic) + +instance P.Pinchable AStruct + + +structSpec :: Spec +structSpec = describe "Struct" $ do + + it "can pinch and unpinch" $ do + P.pinch (AStruct (G.putField "foo") (G.putField Nothing)) + `shouldBe` vstruct [(1, vbin_ "foo")] + + P.pinch (AStruct (G.putField "bar") (G.putField $ Just 42)) + `shouldBe` vstruct + [ (1, vbin_ "bar") + , (5, vi32_ 42) + ] + + P.unpinch (vstruct [(1, vbin_ "hello")]) + `shouldBe` Right + (AStruct (G.putField "hello") (G.putField Nothing)) + + P.unpinch + (vstruct + [ (1, vbin_ "hello") + , (5, vi32_ 42) + ]) `shouldBe` + Right (AStruct (G.putField "hello") (G.putField $ Just 42)) + + it "ignores unrecognized fields" $ do + P.unpinch + (vstruct + [ (1, vbin_ "foo") + , (2, vi32_ 42) + ]) `shouldBe` + Right (AStruct (G.putField "foo") (G.putField Nothing)) + + P.unpinch + (vstruct + [ (1, vbin_ "foo") + , (4, vbyt_ 12) + , (5, vi32_ 34) + ]) `shouldBe` + Right (AStruct (G.putField "foo") (G.putField $ Just 34)) + + it "rejects missing required fields" $ + (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (vstruct + [ (4, vbyt_ 12) + , (5, vi32_ 34) + ]) `leftShouldContain` "1 is absent" + + it "rejects invalid types" $ + (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (vstruct + [ (1, vlist_ [vi32 42]) + ]) `leftShouldContain` "has the incorrect type" + + +spec :: Spec +spec = do + enumSpec + unionSpec + structSpec diff --git a/tests/Pinch/Internal/ParserSpec.hs b/tests/Pinch/Internal/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/ParserSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +module Pinch.Internal.ParserSpec (spec) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Data.Either (isLeft) +import Data.Word (Word8) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import qualified Data.ByteString as B + +import Pinch.Arbitrary + +import qualified Pinch.Internal.Parser as P + + +parse :: [Word8] -> P.Parser a -> Either String a +parse s p = P.runParser p (B.pack s) + + +parseCases + :: (Show a, Eq a) + => P.Parser a -> [([Word8], a)] -> Expectation +parseCases parser = mapM_ . uncurry $ \bytes expected -> + (bytes `parse` parser) `shouldBe` Right expected + + +spec :: Spec +spec = describe "Parser" $ do + + it "can succeed" $ + P.runParser (return 42) "" `shouldBe` Right (42 :: Int) + + it "can fail" $ + (P.runParser (fail "great sadness") "" :: Either String ()) + `shouldBe` Left "great sadness" + + it "can parse 8-bit integers" $ + parseCases P.int8 + [ ([0x01], 1) + , ([0x05], 5) + , ([0x7f], 127) + , ([0xff], -1) + , ([0x80], -128) + ] + + it "can parse 16-bit integers" $ + parseCases P.int16 + [ ([0x00, 0x01], 1) + , ([0x00, 0xff], 255) + , ([0x01, 0x00], 256) + , ([0x01, 0x01], 257) + , ([0x7f, 0xff], 32767) + , ([0xff, 0xff], -1) + , ([0xff, 0xfe], -2) + , ([0xff, 0x00], -256) + , ([0xff, 0x01], -255) + , ([0x80, 0x00], -32768) + ] + + it "can parse 32-bit integers" $ + parseCases P.int32 + [ ([0x00, 0x00, 0x00, 0x01], 1) + , ([0x00, 0x00, 0x00, 0xff], 255) + , ([0x00, 0x00, 0xff, 0xff], 65535) + , ([0x00, 0xff, 0xff, 0xff], 16777215) + , ([0x7f, 0xff, 0xff, 0xff], 2147483647) + , ([0xff, 0xff, 0xff, 0xff], -1) + , ([0xff, 0xff, 0xff, 0x00], -256) + , ([0xff, 0xff, 0x00, 0x00], -65536) + , ([0xff, 0x00, 0x00, 0x00], -16777216) + , ([0x80, 0x00, 0x00, 0x00], -2147483648) + ] + + it "can parse 64-bit integers" $ + parseCases P.int64 + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1) + , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295) + , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775) + , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 281474976710655) + , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 72057594037927935) + , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], 9223372036854775807) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], -1) + , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], -4294967296) + , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], -1099511627776) + , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -281474976710656) + , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -72057594037927936) + , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808) + ] + + it "can parse doubles" $ + parseCases P.double + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001) + , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], 1.1) + , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], -1.1) + , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], 3.141592653589793) + , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001) + ] + + describe "take" $ do + + prop "returns the requested number of bytes" $ + \n (SomeByteString bs) -> + B.length bs >= n ==> + (B.length <$> P.runParser (P.take n) bs) === Right n + + prop "fails when input is too short" $ + \n (SomeByteString bs) -> + B.length bs < n ==> isLeft (P.runParser (P.take n) bs) diff --git a/tests/Pinch/Internal/PinchableSpec.hs b/tests/Pinch/Internal/PinchableSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/PinchableSpec.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Pinch.Internal.PinchableSpec (spec) where + +import Control.Applicative +import Control.Monad +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int (Int16, Int32, Int8) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Vector (Vector) +import Test.Hspec +import Test.Hspec.QuickCheck + +import qualified Data.ByteString as B +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Vector as Vec + +import Pinch.Arbitrary +import Pinch.Expectations +import Pinch.Internal.Pinchable ((.:), (.:?), (.=), (?=)) +import Pinch.Internal.Util + +import qualified Pinch.Internal.Pinchable as P +import qualified Pinch.Internal.TType as T +import qualified Pinch.Internal.Value as V + + +data AnEnum = EnumA | EnumB | EnumC + deriving (Show, Ord, Eq) + +instance P.Pinchable AnEnum where + type Tag AnEnum = T.TEnum + + pinch EnumA = P.pinch (1 :: Int32) + pinch EnumB = P.pinch (2 :: Int32) + pinch EnumC = P.pinch (3 :: Int32) + + unpinch = P.unpinch >=> \v -> case (v :: Int32) of + 1 -> Right EnumA + 2 -> Right EnumB + 3 -> Right EnumC + _ -> Left "Unknown enum value" + +enumSpec :: Spec +enumSpec = describe "Enum" $ do + + it "can pinch and unpinch" $ do + P.pinch EnumA `shouldBe` vi32 1 + P.pinch EnumB `shouldBe` vi32 2 + P.pinch EnumC `shouldBe` vi32 3 + + P.unpinch (vi32 1) `shouldBe` Right EnumA + P.unpinch (vi32 2) `shouldBe` Right EnumB + P.unpinch (vi32 3) `shouldBe` Right EnumC + + it "reject invalid values" $ + P.unpinch (vi32 4) `shouldBe` + (Left "Unknown enum value" :: Either String AnEnum) + + +data AUnion + = UnionDouble Double + | UnionByte Int8 + | UnionSet (Set AnEnum) + deriving (Show, Ord, Eq) + +instance P.Pinchable AUnion where + type Tag AUnion = T.TUnion + + pinch (UnionDouble d) = P.union 1 d + pinch (UnionByte i) = P.union 2 i + pinch (UnionSet s) = P.union 5 s + + unpinch m = + UnionDouble <$> m .: 1 + <|> UnionByte <$> m .: 2 + <|> UnionSet <$> m .: 5 + +unionSpec :: Spec +unionSpec = describe "Union" $ do + + prop "can pinch (1)" $ \dub -> + P.pinch (UnionDouble dub) `shouldBe` + vstruct [(1, vdub_ dub)] + + prop "can pinch (2)" $ \byt -> + P.pinch (UnionByte byt) `shouldBe` + vstruct [(2, vbyt_ byt)] + + it "can pinch (3)" $ + P.pinch (UnionSet $ S.fromList [EnumA, EnumB]) `shouldBe` + vstruct [(5, vset_ [vi32 1, vi32 2])] + + it "can unpinch" $ do + P.unpinch (vstruct [(1, vdub_ 12.34)]) + `shouldBe` Right (UnionDouble 12.34) + + P.unpinch (vstruct [(2, vbyt_ 123)]) + `shouldBe` Right (UnionByte 123) + + P.unpinch + (vstruct [(5, vset_ [vi32 1, vi32 2])]) + `shouldBe` Right (UnionSet $ S.fromList [EnumA, EnumB]) + + it "reject invalid types" $ do + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(1, vi32_ 1)]) + `leftShouldContain` "is absent" + + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(2, vbool_ True)]) + `leftShouldContain` "is absent" + + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(5, vlist_ [vi32 1, vi32 2])]) + `leftShouldContain` "has the incorrect type" + + it "reject invalid IDs" $ + (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (vstruct [(3, vdub_ 1.0)]) + `leftShouldContain` "is absent" + + +data AStruct = AStruct ByteString (Maybe Int32) + deriving (Show, Ord, Eq) + +instance P.Pinchable AStruct where + type Tag AStruct = T.TStruct + + pinch (AStruct a b) = P.struct [1 .= a, 5 ?= b] + unpinch m = AStruct <$> m .: 1 <*> m .:? 5 + +structSpec :: Spec +structSpec = describe "Struct" $ do + + it "can pinch and unpinch" $ do + P.pinch (AStruct "foo" Nothing) + `shouldBe` vstruct [(1, vbin_ "foo")] + + P.pinch (AStruct "bar" (Just 42)) + `shouldBe` vstruct + [ (1, vbin_ "bar") + , (5, vi32_ 42) + ] + + P.unpinch (vstruct [(1, vbin_ "hello")]) + `shouldBe` Right (AStruct "hello" Nothing) + + P.unpinch + (vstruct + [ (1, vbin_ "hello") + , (5, vi32_ 42) + ]) `shouldBe` Right (AStruct "hello" (Just 42)) + + it "ignores unrecognized fields" $ do + P.unpinch + (vstruct + [ (1, vbin_ "foo") + , (2, vi32_ 42) + ]) `shouldBe` Right (AStruct "foo" Nothing) + + P.unpinch + (vstruct + [ (1, vbin_ "foo") + , (4, vbyt_ 12) + , (5, vi32_ 34) + ]) `shouldBe` Right (AStruct "foo" (Just 34)) + + it "rejects missing required fields" $ + (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (vstruct + [ (4, vbyt_ 12) + , (5, vi32_ 34) + ]) `leftShouldContain` "1 is absent" + + it "rejects invalid types" $ + (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (vstruct + [ (1, vlist_ [vi32 42]) + ]) `leftShouldContain` "has the incorrect type" + + +primitivesSpec :: Spec +primitivesSpec = do + + it "can pinch and unpinch Bools" $ do + P.pinch True `shouldBe` vbool True + P.pinch False `shouldBe` vbool False + + P.unpinch (vbool True) `shouldBe` Right True + P.unpinch (vbool False) `shouldBe` Right False + + prop "can pinch and unpinch Int8" $ \i -> do + P.pinch i `shouldBe` vbyt i + P.unpinch (vbyt i) `shouldBe` Right i + + prop "can pinch and unpinch Int32" $ \i -> do + P.pinch i `shouldBe` vi32 i + P.unpinch (vi32 i) `shouldBe` Right i + + prop "can pinch and unpinch Int64" $ \i -> do + P.pinch i `shouldBe` vi64 i + P.unpinch (vi64 i) `shouldBe` Right i + + prop "can pinch and unpinch Double" $ \d -> do + P.pinch d `shouldBe` vdub d + P.unpinch (vdub d) `shouldBe` Right d + + prop "can pinch and unpinch ByteString" $ \(SomeByteString bs) -> do + P.pinch bs `shouldBe` vbin bs + P.unpinch (vbin bs) `shouldBe` Right bs + + it "can pinch and unpinch Text" $ do + P.pinch ("☕️" :: Text) + `shouldBe` vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f]) + + P.unpinch (vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f])) + `shouldBe` Right ("☕️" :: Text) + + +containerSpec :: Spec +containerSpec = do + + describe "Vector" $ do + it "can pinch and unpinch" $ do + + P.pinch (Vec.fromList [1, 2, 3 :: Int32]) + `shouldBe` vlist [vi32 1, vi32 2, vi32 3] + + P.unpinch (vlist [vi32 1, vi32 2, vi32 3]) + `shouldBe` Right (Vec.fromList [1, 2, 3 :: Int32]) + + it "rejects type mismatch" $ + (P.unpinch :: V.Value T.TList -> Either String (Vector Int8)) + (vlist [vi32 1, vi32 2, vi32 3]) + `leftShouldContainAll` + ["Type mismatch", "Expected TByte", "Got TInt32"] + + describe "List" $ do + + it "can pinch and unpinch" $ do + + P.pinch ([1, 2, 3] :: [Int32]) + `shouldBe` vlist [vi32 1, vi32 2, vi32 3] + + P.unpinch (vlist [vi32 1, vi32 2, vi32 3]) + `shouldBe` Right ([1, 2, 3] :: [Int32]) + + it "rejects type mismatch" $ + (P.unpinch :: V.Value T.TList -> Either String [Int8]) + (vlist [vi32 1, vi32 2, vi32 3]) + `leftShouldContain` "Type mismatch" + + describe "HashSet" $ do + it "can pinch and unpinch" $ do + + P.pinch (HS.fromList [1, 2, 3 :: Int32]) + `shouldBe` vset [vi32 1, vi32 2, vi32 3] + + P.unpinch (vset [vi32 1, vi32 2, vi32 3]) + `shouldBe` Right (HS.fromList [1, 2, 3 :: Int32]) + + it "rejects type mismatch" $ + (P.unpinch :: V.Value T.TSet -> Either String (HashSet Int8)) + (vset [vi32 1, vi32 2, vi32 3]) + `leftShouldContain` "Type mismatch" + + describe "Set" $ do + it "can pinch and unpinch" $ do + + P.pinch (S.fromList [1, 2, 3 :: Int32]) + `shouldBe` vset [vi32 1, vi32 2, vi32 3] + + P.unpinch (vset [vi32 1, vi32 2, vi32 3]) + `shouldBe` Right (S.fromList [1, 2, 3 :: Int32]) + + it "rejects type mismatch" $ + (P.unpinch :: V.Value T.TSet -> Either String (Set Int8)) + (vset [vi32 1, vi32 2, vi32 3]) + `leftShouldContain` "Type mismatch" + + describe "HashMap" $ do + + it "can pinch and unpinch" $ do + + P.pinch (HM.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)]) + `shouldBe` vmap + [ (vbin "a", vi16 1) + , (vbin "b", vi16 2) + ] + + P.unpinch + (vmap [ (vbin "a", vi16 1) + , (vbin "b", vi16 2) + ]) `shouldBe` + Right + (HM.fromList + [("a", 1), ("b", 2) :: (ByteString, Int16)]) + + it "rejects key type mismatch" $ + (P.unpinch :: V.Value T.TMap -> Either String (HashMap Int32 Int16)) + (vmap [(vbin "a", vi16 1)]) + `leftShouldContain` "Type mismatch" + + it "rejects value type mismatch" $ + (P.unpinch :: V.Value T.TMap -> Either String (HashMap ByteString Bool)) + (vmap [(vbin "a", vi16 1)]) + `leftShouldContain` "Type mismatch" + + describe "Map" $ do + + it "can pinch and unpinch" $ do + + P.pinch (M.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)]) + `shouldBe` vmap + [ (vbin "a", vi16 1) + , (vbin "b", vi16 2) + ] + + P.unpinch + (vmap [ (vbin "a", vi16 1) + , (vbin "b", vi16 2) + ]) `shouldBe` + Right + (M.fromList + [("a", 1), ("b", 2) :: (ByteString, Int16)]) + + it "rejects key type mismatch" $ + (P.unpinch :: V.Value T.TMap -> Either String (Map Int32 Int16)) + (vmap [(vbin "a", vi16 1)]) + `leftShouldContain` "Type mismatch" + + it "rejects value type mismatch" $ + (P.unpinch :: V.Value T.TMap -> Either String (Map ByteString Bool)) + (vmap [(vbin "a", vi16 1)]) + `leftShouldContain` "Type mismatch" + + +spec :: Spec +spec = describe "Pinchable" $ do + primitivesSpec + containerSpec + enumSpec + unionSpec + structSpec diff --git a/tests/Pinch/Internal/TTypeSpec.hs b/tests/Pinch/Internal/TTypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/TTypeSpec.hs @@ -0,0 +1,16 @@ +module Pinch.Internal.TTypeSpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck + +import Pinch.Arbitrary () + +import qualified Pinch.Internal.TType as T + +spec :: Spec +spec = describe "TType" $ + + -- silly sanity test + prop "has matching IsTType results" $ \someType -> + case someType of + T.SomeTType typ -> T.ttype `shouldBe` typ diff --git a/tests/Pinch/Internal/Util.hs b/tests/Pinch/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/Util.hs @@ -0,0 +1,105 @@ +module Pinch.Internal.Util + ( vbin + , vbool + , vbyt + , vdub + , vi16 + , vi32 + , vi64 + , vlist + , vmap + , vsome + , vstruct + , vset + + , vstruct_ + , vset_ + , vlist_ + , vmap_ + , vdub_ + , vbyt_ + , vi16_ + , vi32_ + , vi64_ + , vbool_ + , vbin_ + ) where + +import Data.ByteString (ByteString) +import Data.Int + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Vector as V + +import Pinch.Internal.TType +import Pinch.Internal.Value + +vsome :: IsTType a => Value a -> SomeValue +vsome = SomeValue + +vstruct_ :: [(Int16, SomeValue)] -> SomeValue +vstruct_ = vsome . vstruct + +vset_ :: IsTType a => [Value a] -> SomeValue +vset_ = vsome . vset + +vlist_ :: IsTType a => [Value a] -> SomeValue +vlist_ = vsome . vlist + +vmap_ :: (IsTType k, IsTType v) => [(Value k, Value v)] -> SomeValue +vmap_ = vsome . vmap + +vdub_ :: Double -> SomeValue +vdub_ = vsome . vdub + +vbyt_ :: Int8 -> SomeValue +vbyt_ = vsome . vbyt + +vi16_ :: Int16 -> SomeValue +vi16_ = vsome . vi16 + +vi32_ :: Int32 -> SomeValue +vi32_ = vsome . vi32 + +vi64_ :: Int64 -> SomeValue +vi64_ = vsome . vi64 + +vbool_ :: Bool -> SomeValue +vbool_ = vsome . vbool + +vbin_ :: ByteString -> SomeValue +vbin_ = vsome . vbin + +vstruct :: [(Int16, SomeValue)] -> Value TStruct +vstruct = VStruct . HM.fromList + +vset :: IsTType a => [Value a] -> Value TSet +vset = VSet . HS.fromList + +vlist :: IsTType a => [Value a] -> Value TList +vlist = VList . V.fromList + +vmap :: (IsTType k, IsTType v) => [(Value k, Value v)] -> Value TMap +vmap = VMap . HM.fromList + +vdub :: Double -> Value TDouble +vdub = VDouble + +vbyt :: Int8 -> Value TByte +vbyt = VByte + +vi16 :: Int16 -> Value TInt16 +vi16 = VInt16 + +vi32 :: Int32 -> Value TInt32 +vi32 = VInt32 + +vi64 :: Int64 -> Value TInt64 +vi64 = VInt64 + +vbool :: Bool -> Value TBool +vbool = VBool + +vbin :: ByteString -> Value TBinary +vbin = VBinary diff --git a/tests/Pinch/Internal/ValueSpec.hs b/tests/Pinch/Internal/ValueSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/ValueSpec.hs @@ -0,0 +1,18 @@ +module Pinch.Internal.ValueSpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Pinch.Arbitrary () + +import qualified Pinch.Internal.Value as V + +spec :: Spec +spec = describe "Value" $ do + + prop "is equal to itself" $ \(V.SomeValue v) -> + v === v + + prop "can be cast via SomeValue" $ \(V.SomeValue v) -> + V.castValue (V.SomeValue v) === Just v diff --git a/tests/Pinch/Protocol/BinarySpec.hs b/tests/Pinch/Protocol/BinarySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Protocol/BinarySpec.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pinch.Protocol.BinarySpec (spec) where + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Word (Word8) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB + +import Pinch.Arbitrary () +import Pinch.Internal.Message +import Pinch.Internal.TType +import Pinch.Internal.Util +import Pinch.Internal.Value (SomeValue (..), Value (..)) +import Pinch.Protocol (Protocol (..)) +import Pinch.Protocol.Binary (binaryProtocol) + + +serialize :: IsTType a => Value a -> ByteString +serialize = toStrict . BB.toLazyByteString . snd . serializeValue binaryProtocol + + +deserialize :: IsTType a => ByteString -> Either String (Value a) +deserialize = deserializeValue binaryProtocol + + +serializeMsg :: Message -> ByteString +serializeMsg = + toStrict . BB.toLazyByteString . snd . serializeMessage binaryProtocol + +deserializeMsg :: ByteString -> Either String Message +deserializeMsg = deserializeMessage binaryProtocol + + +-- | For each given pair, verifies that parsing the byte array yields the +-- value, and that serializing the value yields the byte array. +readWriteCases :: IsTType a => [([Word8], Value a)] -> Expectation +readWriteCases = mapM_ . uncurry $ \bytes value -> do + let bs = B.pack bytes + deserialize bs `shouldBe` Right value + serialize value `shouldBe` bs + + +readWriteMessageCases :: [([Word8], Message)] -> Expectation +readWriteMessageCases = mapM_ . uncurry $ \bytes msg -> do + let bs = B.pack bytes + deserializeMsg bs `shouldBe` Right msg + serializeMsg msg `shouldBe` bs + + +readMessageCases :: [([Word8], Message)] -> Expectation +readMessageCases = mapM_ . uncurry $ \bytes msg -> + deserializeMsg (B.pack bytes) `shouldBe` Right msg + + +-- | For each pair, verifies that if the given TType is parsed, the request +-- fails to parse because the type ID was invalid. +invalidTypeIDCases :: [(SomeTType, [Word8])] -> Expectation +invalidTypeIDCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v + where + go :: forall a. IsTType a => TType a -> [Word8] -> Expectation + go _ bytes = + case deserialize (B.pack bytes) :: Either String (Value a) of + Right v -> expectationFailure $ + "Expected " ++ show bytes ++ " to fail to parse. " ++ + "Got: " ++ show v + Left msg -> msg `shouldContain` "Unknown TType" + + +-- | For each pair, verifies that if the given TType is parsed, the request +-- fails to parse because the input was too short. +tooShortCases :: [(SomeTType, [Word8])] -> Expectation +tooShortCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v + where + go :: forall a. IsTType a => TType a -> [Word8] -> Expectation + go _ bytes = + case deserialize (B.pack bytes) :: Either String (Value a) of + Right v -> expectationFailure $ + "Expected " ++ show bytes ++ " to fail to parse. " ++ + "Got: " ++ show v + Left msg -> msg `shouldContain` "Input is too short" + + +spec :: Spec +spec = describe "BinaryProtocol" $ do + + prop "can roundtrip values" $ \(SomeValue someVal) -> + deserialize (serialize someVal) === Right someVal + + prop "can roundtrip messages" $ \(msg :: Message) -> + deserializeMsg (serializeMsg msg) == Right msg + + it "can read and write booleans" $ readWriteCases + [ ([0x01], vbool True) + , ([0x00], vbool False) + ] + + it "can read and write binary" $ readWriteCases + [ ([ 0x00, 0x00, 0x00, 0x00 ], vbin "") + , ([ 0x00, 0x00, 0x00, 0x05 -- length = 5 + , 0x68, 0x65, 0x6c, 0x6c, 0x6f -- hello + ], vbin "hello") + ] + + it "can read and write structs" $ readWriteCases + [ ([0x00], vstruct []) + + , ([ 0x08 -- ttype = i32 + , 0x00, 0x01 -- field ID = 1 + , 0x00, 0x00, 0x00, 0x2a -- 42 + , 0x00 -- stop + ], vstruct [(1, vi32_ 42)]) + + , ([ 0x0F -- ttype = list + , 0x00, 0x02 -- field ID = 2 + + , 0x0B -- ttype binary + , 0x00, 0x00, 0x00, 0x02 -- size = 2 + + , 0x00, 0x00, 0x00, 0x03 -- length = 3 + , 0x66, 0x6f, 0x6f -- foo + + , 0x00, 0x00, 0x00, 0x03 -- length = 3 + , 0x62, 0x61, 0x72 -- bar + + , 0x00 + ], vstruct + [ (2, vlist_ [vbin "foo", vbin "bar"]) + ]) + ] + + it "can read and write maps" $ readWriteCases + [ ([ 0x02, 0x03 -- ktype = bool, vtype = byte + , 0x00, 0x00, 0x00, 0x00 -- count = 0 + ], vmap ([] :: [(Value TBool, Value TByte)])) + , ([ 0x0B, 0x0F -- ktype = binary, vtype = list + , 0x00, 0x00, 0x00, 0x01 -- count = 1 + + -- "world" + , 0x00, 0x00, 0x00, 0x05 -- length = 5 + , 0x77, 0x6f, 0x72, 0x6c, 0x64 -- world + + -- [1, 2, 3] + , 0x03 -- type = byte + , 0x00, 0x00, 0x00, 0x03 -- count = 3 + , 0x01, 0x02, 0x03 -- 1, 2, 3 + ], vmap + [ (vbin "world", vlist [vbyt 1, vbyt 2, vbyt 3]) + ]) + ] + + it "can read and write sets" $ readWriteCases + [ ([0x02, 0x00, 0x00, 0x00, 0x00 + ], vset ([] :: [Value TBool])) + , ([ 0x02 + , 0x00, 0x00, 0x00, 0x01 + , 0x01 + ], vset [vbool True]) + ] + + it "can read and write lists" $ readWriteCases + [ ([0x02, 0x00, 0x00, 0x00, 0x00 + ], vlist ([] :: [Value TBool])) + , ([ 0x02 + , 0x00, 0x00, 0x00, 0x05 + , 0x01, 0x00, 0x00, 0x01, 0x01 + ], vlist + [ vbool True + , vbool False + , vbool False + , vbool True + , vbool True + ]) + ] + + it "fails if the input is too short" $ tooShortCases + [ (SomeTType TBool, []) + , (SomeTType TByte, []) + , (SomeTType TInt16, [0x01]) + , (SomeTType TInt32, [0x01, 0x02, 0x03]) + , (SomeTType TInt64, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07]) + , (SomeTType TDouble, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07]) + , (SomeTType TBinary, [0x00, 0x00, 0x00]) + , (SomeTType TBinary, [0x00, 0x00, 0x00, 0x01]) + , (SomeTType TBinary, [0x00, 0x00, 0x00, 0x02, 0x01]) + + , (SomeTType TMap, [0x02]) + , (SomeTType TMap, [0x02, 0x03]) + , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00]) + , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00, 0x01]) + , (SomeTType TMap, [0x02, 0x03, 0x00, 0x00, 0x00, 0x01, 0x01]) + , (SomeTType TMap, + [0x02, 0x03, 0x00, 0x00, 0x00, 0x02, 0x01, 0x01, 0x01]) + + , (SomeTType TSet, [0x02]) + , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00]) + , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00, 0x01]) + , (SomeTType TSet, [0x02, 0x00, 0x00, 0x00, 0x02, 0x01]) + + , (SomeTType TList, [0x02]) + , (SomeTType TList, [0x02, 0x00, 0x00, 0x00]) + , (SomeTType TList, [0x02, 0x00, 0x00, 0x00, 0x01]) + , (SomeTType TList, [0x02, 0x00, 0x00, 0x00, 0x02, 0x01]) + ] + + it "denies invalid type IDs" $ invalidTypeIDCases + [ (SomeTType TStruct, [0x01, 0x00, 0x01]) + , (SomeTType TMap, [0x05, 0x07, 0x00, 0x00, 0x00, 0x00]) + , (SomeTType TSet, [0x09, 0x00, 0x00, 0x00, 0x00]) + , (SomeTType TList, [0x10, 0x00, 0x00, 0x00, 0x00]) + ] + + it "can read and write messages" $ readWriteMessageCases + [ ([ 0x00, 0x00, 0x00, 0x06 -- length = 6 + , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f -- 'getFoo' + , 0x01 -- type = Call + , 0x00, 0x00, 0x00, 0x2a -- seqId = 42 + , 0x00 -- empty struct + ], Message "getFoo" Call 42 (vstruct [])), + ([ 0x00, 0x00, 0x00, 0x06 -- length = 6 + , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72 -- 'setBar' + , 0x02 -- type = Reply + , 0x00, 0x00, 0x00, 0x01 -- seqId = 1 + , 0x00 + ], Message "setBar" Reply 1 (vstruct [])) + ] + + it "can read strict messages" $ readMessageCases + [ ([ 0x80, 0x01 -- version = 1 + , 0x00, 0x03 -- type = Exception + + , 0x00, 0x00, 0x00, 0x06 -- length = 6 + , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f -- 'getFoo' + + , 0x00, 0x00, 0x00, 0x2a -- seqId = 42 + + , 0x02, 0x00, 0x01, 0x01 -- {1: True} + , 0x00 + ], Message "getFoo" Exception 42 (vstruct [(1, vbool_ True)])) + , ([ 0x80, 0x01 -- version = 1 + , 0x00, 0x04 -- type = EXCEPTION + + , 0x00, 0x00, 0x00, 0x06 -- length = 6 + , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72 -- 'setBar' + + , 0x00, 0x00, 0x00, 0x01 -- seqId = 1 + + , 0x00 + ], Message "setBar" Oneway 1 (vstruct [])) + ] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}