pinch-0.2.0.0: Pinch.hs

{-# LANGUAGE TypeFamilies #-}
-- |
-- Module      :  Pinch
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Pinch defines machinery to specify how types can be encoded into or decoded
-- from Thrift payloads.
--
module Pinch
    (

    -- * Serializing and deserializing

    -- $encodeDecodeValues

      encode
    , decode

    -- * RPC

    -- $rpc

    , encodeMessage
    , decodeMessage

    -- * Pinchable

    , Pinchable(..)
    , Parser
    , runParser

    -- ** Automatically deriving instances

    -- | Pinch supports deriving instances of 'Pinchable' automatically for
    -- types that implement the @Generic@ typeclass provided that they follow
    -- the outlined patterns in their constructors.

    -- *** Structs and exceptions
    -- $genericStruct

    -- *** Unions
    -- $genericUnion

    , Field(..)
    , getField
    , putField
    , field

    , Void(..)

    -- *** Enums
    -- $genericEnum

    , Enumeration(..)
    , enum

    -- ** Manually writing instances

    -- | Instances of 'Pinchable' can be constructed by composing together
    -- existing instances and using the '.=', '.:', etc. helpers.

    -- *** Structs and exceptions
    -- $struct

    -- *** Unions
    -- $union

    -- *** Enums
    -- $enum

    -- ** Helpers

    -- *** @pinch@

    , (.=)
    , (?=)
    , struct
    , union
    , FieldPair

    -- *** @unpinch@

    , (.:)
    , (.:?)

    -- * Value

    -- | 'Value' is an intermediate representation of Thrift payloads tagged
    -- with TType tags. Types that want to be serialized into\/deserialized
    -- from Thrift payloads need only define a way to convert themselves to
    -- and from 'Value' objects via 'Pinchable'.

    , Value
    , SomeValue(..)

    -- * Messages

    , Message
    , mkMessage
    , messageName
    , messageType
    , messageId
    , getMessageBody

    , MessageType(..)

    -- * Protocols

    , Protocol
    , binaryProtocol

    -- * TType

    -- | TType is used to refer to the Thrift protocol-level type of a value.

    , TType
    , IsTType(..)

    -- ** Tags

    -- | TType tags allow writing code that depends on knowing the @TType@ of
    -- values, or asserting conditions on it, at compile time.
    --
    -- For example, values in a map, list, or set must all have the same TType.
    -- This is enforced at the type level by parameterizing 'Value' over these
    -- tags.

    , TBool
    , TByte
    , TDouble
    , TEnum
    , TInt16
    , TInt32
    , TInt64
    , TBinary
    , TStruct
    , TUnion
    , TException
    , TMap
    , TSet
    , TList
    ) where

import Control.Monad
import Data.ByteString (ByteString)
import Data.Int        (Int32)
import Data.Text       (Text)

import Pinch.Internal.Builder   (runBuilder)
import Pinch.Internal.Generic
import Pinch.Internal.Message
import Pinch.Internal.Pinchable
import Pinch.Internal.TType
import Pinch.Internal.Value
import Pinch.Protocol
import Pinch.Protocol.Binary

------------------------------------------------------------------------------

-- $encodeDecodeValues
--
-- Types that can be serialized and deserialized into\/from Thrift values
-- implement the 'Pinchable' typeclass. Instances may be derived automatically
-- using generics, or written out by hand.
--
-- The 'Pinchable' typeclass converts objects into and from 'Value' objects,
-- which act as a direct mapping to the Thrift wire representation.  A
-- 'Protocol' is responsible for converting 'Value' objects to and from
-- bytestrings.
--
-- The 'encode' and 'decode' methods may be used on objects that implement the
-- 'Pinchable' typeclass to get the wire representation directly.
--
-- > +------------+   Pinchable                    Protocol    +------------+
-- > |            |               +------------+               |            |
-- > |            +----pinch------>            +---serialize--->            |
-- > | Your Type  |               |  Value a   |               | ByteString |
-- > |            <---unpinch-----+            <--deserialize--+            |
-- > |            |               +------------+               |            |
-- > |            |                                            |            |
-- > |            +-------------------encode------------------->            |
-- > |            |                                            |            |
-- > |            <-------------------decode-------------------+            |
-- > +------------+                                            +------------+

-- | Encode the given 'Pinchable' value using the given 'Protocol'.
--
-- >>> unpack $ encode binaryProtocol ["a" :: ByteString, "b"]
-- [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]
--
encode :: Pinchable a => Protocol -> a -> ByteString
encode p = runBuilder . serializeValue p . pinch
{-# INLINE encode #-}

-- | Decode a 'Pinchable' value from the using the given 'Protocol'.
--
-- >>> let s = pack [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98]
-- >>> decode binaryProtocol s :: Either String [ByteString]
-- Right ["a","b"]
--
decode :: Pinchable a => Protocol -> ByteString -> Either String a
decode p = deserializeValue p >=> runParser . unpinch
{-# INLINE decode #-}

------------------------------------------------------------------------------

-- $rpc
--
-- Thrift requests implicitly form a struct and responses implicitly form a
-- union. To send\/receive the request\/response, it must be wrapped inside a
-- 'Message'. The 'Message' contains information like the method name, the
-- message ID (to match out of order responses with requests), and whether
-- it contains a request or a response.
--
-- Requests and responses may be wrapped into @Message@ objects using the
-- 'mkMessage' function. The message body can be retrieved back using the
-- 'getMessageBody' function. The 'encodeMessage' and 'decodeMessage'
-- functions may be used to encode and decode messages into\/from bytestrings.
--
-- Consider the service method,
--
-- > User getUser(1: string userName, 2: list<Attribute> attributes)
-- >   throws (1: UserDoesNotExist doesNotExist,
-- >           2: InternalError internalError)
--
-- The request and response for this method implictly take the form:
--
-- > struct getUserRequest {
-- >   1: string userName
-- >   2: list<Attribute> attributes
-- > }
--
-- > union getUserResponse {
-- >   0: User success
-- >   1: UserDoesNotExist doesNotExist
-- >   2: InternalError InternalError
-- > }
--
-- (Note that the field ID 0 is reserved for the return value of the method.)
--
-- Given corresponding data types @GetUserRequest@ and @GetUserResponse@, the
-- client can do something similar to,
--
-- @
-- let req = GetUserRequest "jsmith" []
--     msg = 'mkMessage' "getUser" 'Call' 0 req
-- response <- sendToServer ('encodeMessage' msg)
-- case 'decodeMessage' response of
--     Left err -> handleError err
--     Right msg -> case 'getMessageBody' msg of
--         Left err -> handleError err
--         Right (res :: GetUserResponse) -> handleResponse res
-- @
--
-- Similarly, on the server side,
--
-- @
-- case decodeMessage request of
--     Left err -> handleError err
--     Right msg -> case 'messageName' msg of
--         "getUser" -> case getMessageBody msg of
--             Left err -> handleError err
--             Right (req :: GetUserRequest) -> do
--                 let mid = 'messageId' msg
--                 res <- handleGetUser req
--                 return (mkMessage "getUser" 'Reply' mid res)
--                 -- Note that the response MUST contain the same
--                 -- message ID as its request.
--         _ -> handleUnknownMethod
-- @

-- | Encode the 'Message' using the given 'Protocol'.
--
-- @
-- let request = GetUserRequest (putField "jsmith") (putField [])
--     message = 'mkMessage' "getUser" Call 42 request
-- in encodeMessage binaryProtocol message
-- @
--
encodeMessage :: Protocol -> Message -> ByteString
encodeMessage p = runBuilder . serializeMessage p
{-# INLINE encodeMessage #-}

-- | Decode a 'Message' using the given 'Protocol'.
--
-- >>> decodeMessage binaryProtocol bs >>= getMessageBody :: Either String GetUserRequest
-- Right (GetUserRequest {userName = Field "jsmith", userAttributes = Field []})
--
decodeMessage :: Protocol -> ByteString -> Either String Message
decodeMessage = deserializeMessage
{-# INLINE decodeMessage #-}

-- | Build a @Message@.
mkMessage
    :: (Pinchable a, Tag a ~ TStruct)
    => Text
    -- ^ Name of the target method.
    -> MessageType
    -- ^ Type of the message.
    -> Int32
    -- ^ Message ID.
    -> a
    -- ^ Message payload. This must be an object which serializes into a
    -- struct.
    -> Message
mkMessage name typ mid body = Message name typ mid (pinch body)
{-# INLINE mkMessage #-}

-- | Read the message contents.
--
-- This returns a @Left@ result if the message contents do not match the
-- requested type.
getMessageBody
    :: (Pinchable a, Tag a ~ TStruct) => Message -> Either String a
getMessageBody = runParser . unpinch . messagePayload
{-# INLINE getMessageBody #-}

------------------------------------------------------------------------------

-- $genericStruct
--
-- Given the struct,
--
-- > struct User {
-- >   1: required string name
-- >   2: optional string emailAddress
-- > }
--
-- A @Pinchable@ instance for it can be automatically derived by wrapping
-- fields of the data type with the 'Field' type and specifying the field
-- identifier as a type-level numeral. Fields which hold a @Maybe@ value are
-- considered optional.
--
-- @
-- data User = User
--     { userName         :: 'Field' 1 Text
--     , userEmailAddress :: Field 2 (Maybe Text)
--     }
--   deriving (Generic)
--
-- instance Pinchable User
-- @
--
-- The @DeriveGeneric@ extension is required to automatically derive instances
-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use
-- type-level numerals.

------------------------------------------------------------------------------

-- $genericUnion
--
-- As with structs and exceptions, fields of the data type representing a
-- union must be tagged with 'Field', but to satisfy the property of a union
-- that only one value is set at a time, they must be on separate
-- constructors.
--
-- For example, given the union,
--
-- > union Item {
-- >   1: binary bin
-- >   2: string str
-- >   3: i32    int
-- > }
--
-- A @Pinchable@ instance can be derived like so,
--
-- > data Item
-- >     = ItemBin (Field 1 ByteString)
-- >     | ItemStr (Field 2 Text)
-- >     | ItemInt (Field 3 Int32)
-- >   deriving (Generic)
-- >
-- > instance Pinchable Item
--
-- The @DeriveGeneric@ extension is required to automatically derive instances
-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use
-- type-level numerals.
--
-- If the union represents the response of a service method which returns a
-- @void@ result, the type 'Void' may be used.
--
-- @
-- data GetFooResponse
--   = GetFooDoesNotExist  (Field 1 FooDoesNotExist)
--   | GetFooInternalError (Field 2 InternalError)
--   | GetFooSuccess 'Void'
-- @

------------------------------------------------------------------------------

-- $genericEnum
--
-- Given the enum,
--
-- > enum Op {
-- >   Add, Sub, Mul, Div
-- > }
--
-- A @Pinchable@ instance can be derived for it by creating one constructor
-- for each of the enum values and providing it a single 'Enumeration'
-- argument tagged with the enum value.
--
-- @
-- data Op
--     = OpAdd ('Enumeration' 0)
--     | OpSub (Enumeration 1)
--     | OpMul (Enumeration 2)
--     | OpDiv (Enumeration 3)
--   deriving (Generic)
--
-- instance Pinchable Op
-- @
--
-- Note that you need to know the values assigned to the enums. If not
-- specified, Thrift automatically assigns incrementing values to the items in
-- the order they appear starting at 0.
--
-- The @DeriveGeneric@ extension is required to automatically derive instances
-- of the @Generic@ typeclass and the @DataKinds@ extension is required to use
-- type-level numerals.

------------------------------------------------------------------------------

-- $struct
--
-- Given a Thrift struct,
--
-- > struct Post {
-- >   1: optional string subject
-- >   2: required string body
-- > }
--
-- The 'Pinchable' instance for it will be,
--
-- @
-- data Post = Post
--     { postSubject :: Maybe Text
--     , postBody    :: Text
--     }
--
-- instance 'Pinchable' Post where
--     type 'Tag' Post = 'TStruct'
--
--     pinch (Post subject body) =
--         'struct' [ 1 '?=' subject
--                , 2 '.=' body
--                ]
--
--     unpinch value =
--         Post \<$\> value '.:?' 1
--              \<*\> value '.:'  2
-- @
--

------------------------------------------------------------------------------

-- $union
--
-- Given a Thrift union,
--
-- > union PostBody {
-- >   1: string markdown
-- >   2: binary rtf
-- > }
--
-- The 'Pinchable' instance for it will be,
--
-- @
-- data PostBody
--     = PostBodyMarkdown Text
--     | PostBodyRtf ByteString
--
-- instance Pinchable PostBody where
--     type Tag PostBody = 'TUnion'
--
--     pinch (PostBodyMarkdown markdownBody) =
--         'union' 1 markdownBody
--     pinch (PostBodyRtf rtfBody) =
--         union 2 rtfBody
--
--     unpinch v = PostBodyMarkdown \<$\> v .: 1
--             \<|\> PostBodyRtf      \<$\> v .: 2
-- @

------------------------------------------------------------------------------

-- $enum
--
-- Given an enum,
--
-- > enum Role {
-- >   DISABLED = 0,
-- >   USER,
-- >   ADMIN,
-- > }
--
-- The 'Pinchable' instance for it will be,
--
-- > data Role = RoleDisabled | RoleUser | RoleAdmin
-- >
-- > instance Pinchable Role where
-- >     type Tag Role = TEnum
-- >
-- >     pinch RoleDisabled = pinch (0 :: Int32)
-- >     pinch RoleUser     = pinch (1 :: Int32)
-- >     pinch RoleAdmin    = pinch (2 :: Int32)
-- >
-- >     unpinch v = do
-- >        value <- unpinch v
-- >        case (value :: Int32) of
-- >            0 -> Right RoleDisabled
-- >            1 -> Right RoleUser
-- >            2 -> Right RoleAdmin
-- >            _ -> Left $ "Unknown role: " ++ show value