packages feed

fbmessenger-api (empty) → 0.1.0.0

raw patch · 30 files changed

+1656/−0 lines, 30 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, case-insensitive, fbmessenger-api, filepath, hspec, http-client, http-client-tls, http-media, http-types, mime-types, servant, servant-client, servant-server, stm, string-conversions, text, transformers, unordered-containers, warp

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Marcello Seri, Federico Rampazzo (c) 2016++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 Marcello Seri 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example-app/example.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad (when)+import Control.Monad.Trans.Except (ExceptT)+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Text as T hiding (map)+import Network.HTTP.Client hiding (Proxy, port)+import Network.HTTP.Client.TLS+import Network.Wai.Handler.Warp+import Servant+import System.Environment+import System.IO+import Web.FBMessenger.API.Bot++type WebHookAPI = "webhook" :> +    QueryParam "hub.verify_token" String :> +    QueryParam "hub.challenge" String :> +    Get '[PlainText] String+  :<|> "webhook" :>+    ReqBody '[JSON] RemoteEventList :>+    Post '[PlainText] String++webHookAPI :: Proxy WebHookAPI+webHookAPI = Proxy++server :: String -> Server WebHookAPI+server verifyTokenStored = +  webhook_verify+  :<|> webhook_message+  where+    webhook_verify :: Maybe String -> Maybe String -> ExceptT ServantErr IO String+    webhook_verify (Just verifyToken) (Just challenge) +      | verifyToken == verifyTokenStored = return challenge+    webhook_verify _ _ = throwError err500 { errBody = "Error, wrong validation token"}++    webhook_message :: RemoteEventList -> ExceptT ServantErr IO String+    webhook_message (RemoteEventList res) = do+      let _ = map (echoMessage . evt_messaging) res+      return "ok"++    echoMessage :: [EventMessage] -> IO ()+    echoMessage msgs = mapM_ process msgs >> return ()+      where +        process msg = case evtContent msg of+            EmTextMessage _ _ text -> do+              case recipient (Just $ evtSenderId msg) Nothing of+                Nothing -> return ()+                Just r -> do+                  let req = sendTextMessageRequest Nothing r text+                  m <- newManager tlsManagerSettings+                  let t = Token $ T.pack verifyTokenStored+                  let _ = sendTextMessage (Just $ t) req m+                  return ()+            _ -> return ()+++main :: IO ()+main = do+    hSetBuffering stdout LineBuffering+    env <- getEnvironment+    let port = maybe 3000 read $ lookup "PORT" env+    let verifyToken = fromMaybe "" $ lookup "VERIFY_TOKEN" env+    when (verifyToken == "") (putStrLn "Please set VERIFY_TOKEN to a safe string")+    putStrLn $ "Server listening on port " ++ show port+    run port $ serve webHookAPI $ server verifyToken
+ fbmessenger-api.cabal view
@@ -0,0 +1,80 @@+name:                fbmessenger-api+version:             0.1.0.0+synopsis:            High-level bindings to Facebook Messenger Platform API+description:         Please see README.md+homepage:            https://github.com/mseri/fbmessenger-api#readme+license:             BSD3+license-file:        LICENSE+author:              Marcello Seri+maintainer:          marcello.seri@gmail.com+copyright:           2016 Marcello Seri, Federico Rampazzo+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10+data-files:          test-files/*.json++library+  hs-source-dirs:      src+  ghc-options:         -Wall -fwarn-tabs -fno-warn-name-shadowing -fwarn-pointless-pragmas+  exposed-modules:     Web.FBMessenger.API.Bot+                     , Web.FBMessenger.API.Bot.SendAPI+                     , Web.FBMessenger.API.Bot.Responses+                     , Web.FBMessenger.API.Bot.Requests+                     , Web.FBMessenger.API.Bot.WebhookAPI+  other-modules:       Web.FBMessenger.API.Bot.JsonExt+                     , Servant.Client.MultipartFormData+  build-depends:       base >= 4.7 && < 5+                     -- below this line in alphabetical order+                     , aeson+                     , bytestring+                     , http-client+                     , servant == 0.7.*+                     , servant-client == 0.7.*+                     , text+                     , transformers+                     , unordered-containers+                     -- for Servant.Client.MultipartFormData and interaction with it+                     , http-media         +                     , http-types+                     , mime-types+                     , string-conversions+                     -- for more direct error responses manipulation+                     , case-insensitive+  default-language:    Haskell2010++executable example+  main-is:            example.hs+  hs-source-dirs:     example-app+  ghc-options:        -fwarn-tabs -O2 -Wall -threaded+  build-depends:      base+                    ,  aeson+                    ,  http-client+                    ,  http-client-tls+                    ,  fbmessenger-api+                    ,  servant == 0.7.*+                    ,  servant-server == 0.7.*+                    ,  stm+                    ,  text+                    ,  transformers+                    ,  warp+  default-language:   Haskell2010++test-suite fbmessenger-api-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , aeson+                     , bytestring+                     , fbmessenger-api+                     , filepath+                     , hspec+                     , text+                     -- , http-client-tls+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://mseri@bitbucket.org/bad4ss/haskell-fb-messenger-api.git
+ src/Servant/Client/MultipartFormData.hs view
@@ -0,0 +1,105 @@+--+-- For additional informations on multipart form data see: https://github.com/haskell-servant/servant/issues/133#issuecomment-125235662+--+-- The code that follows comes from: https://github.com/klappvisor/haskell-telegram-api/pull/24+-- Code Licenseded under BSD3 - Copyright Alexey Rodiontsev (c) 2015+++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.Client.MultipartFormData+  ( ToMultipartFormData (..)+  , MultipartFormDataReqBody+  ) where++import           Control.Exception+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except+import           Data.ByteString.Lazy       hiding (pack, filter, map, null, elem)+import           Data.Proxy+import           Data.String.Conversions+import           Data.Typeable              (Typeable)+import           Network.HTTP.Client        hiding (Proxy, path)+import qualified Network.HTTP.Client        as Client+import           Network.HTTP.Client.MultipartFormData+import           Network.HTTP.Media+import           Network.HTTP.Types+import qualified Network.HTTP.Types         as H+import qualified Network.HTTP.Types.Header  as HTTP+import           Servant.API+import           Servant.Client+import           Servant.Common.Req++-- | A type that can be converted to a multipart/form-data value.+class ToMultipartFormData a where+  -- | Convert a Haskell value to a multipart/form-data-friendly intermediate type.+  toMultipartFormData :: a -> [Part]++-- | Extract the request body as a value of type @a@.+data MultipartFormDataReqBody a+    deriving (Typeable)++instance (ToMultipartFormData b, MimeUnrender ct a, cts' ~ (ct ': cts)+  ) => HasClient (MultipartFormDataReqBody b :> Post cts' a) where+  type Client (MultipartFormDataReqBody b :> Post cts' a)+    = b -> Manager -> BaseUrl -> ClientM a+  clientWithRoute Proxy req reqData manager baseurl =+    let reqToRequest' req' baseurl' = do+          requestWithoutBody <- reqToRequest req' baseurl'+          formDataBody (toMultipartFormData reqData) requestWithoutBody+    in snd <$> performRequestCT' reqToRequest' (Proxy :: Proxy ct) H.methodPost req manager baseurl++-- copied `performRequest` from servant-0.7.1, then modified so it takes a variant of `reqToRequest`+-- as an argument.+performRequest' :: (Req -> BaseUrl -> IO Request)+               -> Method -> Req -> Manager -> BaseUrl+               -> ClientM ( Int, ByteString, MediaType+                          , [HTTP.Header], Response ByteString)+performRequest' reqToRequest' reqMethod req manager reqHost = do+  partialRequest <- liftIO $ reqToRequest' req reqHost++  let request = partialRequest { Client.method = reqMethod+                               , checkStatus = \ _status _headers _cookies -> Nothing+                               }++  eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager+  case eResponse of+    Left err ->+      throwE . ConnectionError $ SomeException err++    Right response -> do+      let status = Client.responseStatus response+          body = Client.responseBody response+          hdrs = Client.responseHeaders response+          status_code = statusCode status+      ct <- case lookup "Content-Type" $ Client.responseHeaders response of+                 Nothing -> pure $ "application"//"octet-stream"+                 Just t -> case parseAccept t of+                   Nothing -> throwE $ InvalidContentTypeHeader (cs t) body+                   Just t' -> pure t'+      unless (status_code >= 200 && status_code < 300) $+        throwE $ FailureResponse status ct body+      return (status_code, body, ct, hdrs, response)++-- copied `performRequestCT` from servant-0.7.1, then modified so it takes a variant of `reqToRequest`+-- as an argument.+performRequestCT' :: MimeUnrender ct result =>+  (Req -> BaseUrl -> IO Request) ->+  Proxy ct -> Method -> Req -> Manager -> BaseUrl+    -> ClientM ([HTTP.Header], result)+performRequestCT' reqToRequest' ct reqMethod req manager reqHost = do+  let acceptCT = contentType ct+  (_status, respBody, respCT, hdrs, _response) <-+    performRequest' reqToRequest' reqMethod (req { reqAccept = [acceptCT] }) manager reqHost+  unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody+  case mimeUnrender ct respBody of+    Left err -> throwE $ DecodeFailure err respCT respBody+    Right val -> return (hdrs, val)
+ src/Web/FBMessenger/API/Bot.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds         #-}+--{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+--{-# LANGUAGE TemplateHaskell   #-}++-- | This module provides the Messenger Platform Bot API+module Web.FBMessenger.API.Bot ( module X ) where++import Web.FBMessenger.API.Bot.SendAPI as X+import Web.FBMessenger.API.Bot.Responses as X+import Web.FBMessenger.API.Bot.Requests as X+import Web.FBMessenger.API.Bot.WebhookAPI as X
+ src/Web/FBMessenger/API/Bot/JsonExt.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE FlexibleContexts  #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-- | This module contains helper functions to work with JSON+--   Credits: https://github.com/klappvisor/haskell-telegram-api+module Web.FBMessenger.API.Bot.JsonExt+    (+      toJsonDrop,+      parseJsonDrop+    ) where++import           Data.Aeson+import           Data.Aeson.Types++-- | Method used to drop prefix from field name during serialization+toJsonDrop prefix = genericToJSON defaultOptions {+    fieldLabelModifier = drop prefix+  , omitNothingFields = True+  }++-- | Method used to drop prefix from field name during deserialization+parseJsonDrop prefix = genericParseJSON defaultOptions { fieldLabelModifier = drop prefix }+
+ src/Web/FBMessenger/API/Bot/Requests.hs view
@@ -0,0 +1,526 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeOperators              #-}++{-# OPTIONS_GHC -fno-warn-unused-binds  #-}++-- | This module contains data objects which represents requests to Messenger Platform Bot API+module Web.FBMessenger.API.Bot.Requests +    ( -- * Types+      Button                       (..)+    , BubbleElement                (..)+    , FileUpload                   (..)+    , FileUploadContent            (..)+    , NotificationType             (..)+    , PaymentSummary               (..)+    , PaymentAdjustment            (..)+    , Recipient                    (..)+    , ReceiptItem                  (..)+    , ShippingAddress              (..)+    , SendTextMessageRequest       (..)+    , SendStructuredMessageRequest (..)+    , UploadImageMessageRequest    (..)+    , WelcomeMessageRequest        (..)+    -- * Functions+    , bubbleElement+    , localFileUpload+    , paymentSummary+    , postbackButton+    , receiptItem+    , recipient+    , shippingAddress+    , sendButtonTemplateMessageRequest+    , sendGenericTemplateMessageRequest+    , sendImageMessageRequest+    , sendReceiptTemplateMessageRequest+    , sendTextMessageRequest+    , setWelcomeButtonTemplateMessageRequest+    , setWelcomeGenericTemplateMessageRequest+    , setWelcomeImageMessageRequest+    , setWelcomeTextMessageRequest+    , uploadImageMessageRequest+    , webUrlButton+) where++import           Data.Aeson+import           Data.Aeson.Types+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           GHC.Generics+import           Network.HTTP.Client.MultipartFormData+import           Network.Mime+--import           Prelude hiding (lookup)+import           Servant.Client.MultipartFormData (ToMultipartFormData (..))+import           Web.FBMessenger.API.Bot.JsonExt+++-- | Informations about the recipient of the message+data Recipient = Recipient +  { recipient_id           :: Maybe Text  -- ^ ID of recipient+  , recipient_phone_number :: Maybe Text  -- ^ Phone number of the recipient with the format +1(212)555-2368+  } deriving (Eq, Show, Generic)++instance ToJSON Recipient where+    toJSON = toJsonDrop 10++instance FromJSON Recipient where+    parseJSON = parseJsonDrop 10++-- | Take reciptient id (optional) or phone_number (optional) and return a Maybe Recipient object.+--   Return Nothing when values are either both (Just _) or both Nothing.  +recipient :: Maybe Text -> Maybe Text -> Maybe Recipient+recipient Nothing Nothing   = Nothing+recipient (Just _) (Just _) = Nothing+recipient rid phone_number  = pure $ Recipient rid phone_number +++-- | Push notification type for the message+data NotificationType = Regular        -- ^ will emit a sound/vibration and a phone notification (default)+                      | SilentPush     -- ^ will just emit a phone notification+                      | NoPush         -- ^ will not emit either+                      deriving (Eq, Show)++instance ToJSON NotificationType where+  toJSON Regular    = "REGULAR"+  toJSON SilentPush = "SILENT_PUSH"+  toJSON NoPush     = "NO_PUSH"++instance FromJSON NotificationType where+  parseJSON "REGULAR"     = pure Regular+  parseJSON "SILENT_PUSH" = pure SilentPush+  parseJSON "NO_PUSH"     = pure NoPush+  parseJSON _             = fail "Failed to parse NotificationType"+++-- | This object represents a text message request+--   The message text must be UTF-8, with 320 character limit+data SendTextMessageRequest = SendTextMessageRequest+  { mRecipient        :: Recipient+  , mText             :: Text+  , mNotificationType :: Maybe NotificationType+  } deriving (Eq, Show, Generic)++instance ToJSON SendTextMessageRequest where+  toJSON SendTextMessageRequest{..} = omitNulls [ "recipient" .= mRecipient, "message" .= tw, "notification_type" .= mNotificationType ]+     where tw = object [ "text" .= mText ]+  +instance FromJSON SendTextMessageRequest where+  parseJSON = withObject "send text message" $ \o ->+    let t = o .: "message" >>= (.: "text") in +      SendTextMessageRequest <$> o .: "recipient" <*> t <*> o .:? "notification_type"+    +-- | Take a notification type (optional), a recipient and a text. +--   Return a SendTextMessageRequest. +--   Raise an error if the text is longer than 320 characters.+sendTextMessageRequest :: Maybe NotificationType -> Recipient -> Text -> SendTextMessageRequest+sendTextMessageRequest notificationType recipient text +  | T.length text <= 320 = SendTextMessageRequest recipient text notificationType+  | otherwise            = error "message text too long: the text must be UTF-8, with 320 character limit"+      +  +-- | Payload of attachment for structured messages.+--+--   Although not enforced in any way by this wrapper, the following generic limits are in place+--   (see also https://developers.facebook.com/docs/messenger-platform/send-api-reference#guidelines)+--+--       Title: 80 characters+--       Subtitle: 80 characters+--       Call-to-action title: 20 characters+--       Call-to-action items: 3 buttons+--       Bubbles per message (horizontal scroll): 10 elements+--       +--       Image ratio is 1.91:1+--+ +data ImagePayload = ImagePayload +    { imgUrl :: Text                                -- ^ Image url +    } deriving (Eq, Show)++parseImagePayload :: Object -> Parser ImagePayload+parseImagePayload v = ImagePayload <$> v.: "url"     + +data GenericTemplate = GenericTemplate +    { genElements       :: [BubbleElement]           -- ^ Data for each bubble in message +    } deriving (Eq, Show)++parseGenericTemplate :: Object -> Parser GenericTemplate+parseGenericTemplate v = GenericTemplate <$> v .: "elements"++data ButtonTemplate = ButtonTemplate+    { btnText           :: Text                      -- ^ Text that appears in main body+    , btnButtons        :: [Button]                  -- ^ Set of buttons that appear as call-to-actions+    } deriving (Eq, Show)++parseButtonTemplate :: Object -> Parser ButtonTemplate+parseButtonTemplate v = ButtonTemplate <$> v .: "text" <*> v .: "buttons" ++data ReceiptTemplate = ReceiptTemplate +    { rcpRecipientName   :: Text                      -- ^ Recipient's Name+    , rcpOrderNumber     :: Text                      -- ^ Order number. Must be unique+    , rcpCurrency        :: Text                      -- ^ Currency for order+    , rcpPaymentMethod   :: Text                      -- ^ Payment method details. You may insert an arbitrary string but it is recommended to provide enough information for the person to decipher which payment method and account they used number)+    , rcpTimestamp       :: Maybe Text                -- ^ Timestamp of order+    , rcpOrderUrl        :: Maybe Text                -- ^ URL of order+    , rcpElements        :: [ReceiptItem]             -- ^ Items in order       +    , rcpAddress         :: Maybe ShippingAddress     -- ^ Shipping address. If you do not ship an item, you may omit the field+    , rcpSummary         :: PaymentSummary            -- ^ Payment summary+    , rcpAdjustments     :: Maybe [PaymentAdjustment] -- ^ Payment adjustments. Allow a way to insert adjusted pricing (e.g., sales)+    } deriving (Eq, Show)++parseReceiptTemplate :: Object -> Parser ReceiptTemplate+parseReceiptTemplate v = ReceiptTemplate <$> v .: "recipient_name"+                                         <*> v .: "order_number"+                                         <*> v .: "currency"+                                         <*> v .: "payment_method"+                                         <*> v .:? "timestamp"+                                         <*> v .:? "order_url"+                                         <*> v .: "elements"+                                         <*> v .:? "address"+                                         <*> v .: "summary"+                                         <*> v .:? "adjustments" ++instance ToJSON ImagePayload where+    toJSON ImagePayload{..} = object [ "url" .= imgUrl ]+instance FromJSON ImagePayload where+    parseJSON = withObject "image payload" $ \v -> parseImagePayload v+    +instance ToJSON GenericTemplate where+    toJSON GenericTemplate{..} = object [ "template_type" .= ("generic"::String), "elements" .= genElements ]+instance FromJSON GenericTemplate where+    parseJSON = withObject "generic template payload" $ \v -> parseGenericTemplate v+    +instance ToJSON ButtonTemplate where+    toJSON ButtonTemplate{..} = object [ "template_type" .= ("button"::String), "text" .= btnText, "buttons" .= btnButtons ]+instance FromJSON ButtonTemplate where+    parseJSON = withObject "button template payload" $ \v -> parseButtonTemplate v+    +instance ToJSON ReceiptTemplate where+    toJSON ReceiptTemplate{..} = omitNulls [ "template_type"  .= ("receipt"::String)+                                           , "recipient_name" .= rcpRecipientName+                                           , "order_number"   .= rcpOrderNumber+                                           , "currency"       .= rcpCurrency+                                           , "payment_method" .= rcpPaymentMethod+                                           , "timestamp"      .= rcpTimestamp+                                           , "order_url"      .= rcpOrderUrl+                                           , "elements"       .= rcpElements+                                           , "address"        .= rcpAddress+                                           , "summary"        .= rcpSummary+                                           , "adjustments"    .= rcpAdjustments ]+instance FromJSON ReceiptTemplate where+    parseJSON = withObject "receipt template payload" $ \v -> parseReceiptTemplate v++data AttachmentWrapper = ItImage ImagePayload +                       | ItGeneric GenericTemplate +                       | ItButton ButtonTemplate +                       | ItReceipt ReceiptTemplate deriving (Eq, Show)++instance ToJSON AttachmentWrapper where+    toJSON aw = object [ "type" .= t, "payload" .= p ]+      where +        (t, p) = case aw of+                    ItImage a    -> ("image":: String,    toJSON a)+                    ItGeneric a  -> ("template":: String, toJSON a)+                    ItButton a   -> ("template":: String, toJSON a)+                    ItReceipt a  -> ("template":: String, toJSON a)+instance FromJSON AttachmentWrapper where+    parseJSON = withObject "attachment wrapper" $ \o -> do+      type_   <- (o .: "type") :: Parser String+      payload <- o .: "payload" +      case type_ of+        "image"    -> ItImage <$> parseImagePayload payload+        "template" -> do+          templateType <- (o .: "payload" >>= (.: "template_type")) :: Parser String+          case templateType of+            "generic" -> ItGeneric <$> parseGenericTemplate payload+            "button"  -> ItButton  <$> parseButtonTemplate payload +            "receipt" -> ItReceipt <$> parseReceiptTemplate payload+            _ -> fail "impossible to parse the template type"+        _  -> fail "impossible to parse the attachment wrapper type" +++-- | Type for Button objects. See Button type for additional informations.+data ButtonType = WebUrl | Postback deriving (Eq, Show)++instance ToJSON ButtonType where+  toJSON WebUrl    = "web_url"+  toJSON Postback  = "postback"++instance FromJSON ButtonType where+  parseJSON "web_url"  = pure WebUrl+  parseJSON "postback" = pure Postback+  parseJSON _          = fail "Failed to parse ButtonType"++-- | Button object for structured messages payloads+data Button = Button +  { btn_type    :: ButtonType   -- ^ Value is "web_url" or "postback"+  , btn_title   :: Text         -- ^ Button title+  , btn_url     :: Maybe Text   -- ^ For web_url buttons, this URL is opened in a mobile browser when the button is tapped. Required if type is "web_url"+  , btn_payload :: Maybe Text   -- ^ For postback buttons, this data will be sent back to you via webhook. Required if type is "postback"+  } deriving (Eq, Show, Generic)++instance ToJSON Button where+    toJSON = toJsonDrop 4+instance FromJSON Button where+  parseJSON = parseJsonDrop 4+  +-- | Take the button title and the button url (this URL is opened in a mobile browser when the button is tapped)+--   and return a "web_url" button+webUrlButton :: Text -> Text -> Button+webUrlButton title url = Button WebUrl title (Just url) Nothing++-- | Take the button title and the button payload (this data will be sent back to you via webhook)+--   and return a "postback" button  +postbackButton :: Text -> Text -> Button+postbackButton title payload = Button Postback title Nothing (Just payload)++-- | Bubble element object for structured messages payloads+data BubbleElement = BubbleElement+  { elm_title      :: Text           -- ^ Bubble title+  , elm_item_url   :: Maybe Text     -- ^ URL that is opened when bubble is tapped+  , elm_image_url  :: Maybe Text     -- ^ Bubble image+  , elm_subtitle   :: Maybe Text     -- ^ Bubble subtitle+  , elm_buttons    :: Maybe [Button] -- ^ Set of buttons that appear as call-to-actions+  } deriving (Eq, Show, Generic)++instance ToJSON BubbleElement where+    toJSON = toJsonDrop 4+instance FromJSON BubbleElement where+    parseJSON = parseJsonDrop 4++-- | Take the bubble element title. The buttons will appear as call-to-action in Messenger.+--   Return a bubble Element+bubbleElement :: Text -> BubbleElement+bubbleElement title = BubbleElement title Nothing Nothing Nothing Nothing++data ReceiptItem = ReceiptItem +  { re_title     :: Text         -- ^ Title of item+  , re_subtitle  :: Maybe Text   -- ^ Subtitle of item+  , re_quantity  :: Maybe Int    -- ^ Quantity of item+  , re_price     :: Maybe Int    -- ^ Item price+  , re_currency  :: Maybe Text   -- ^ Currency of price+  , re_image_url :: Maybe Text   -- ^ Image URL of item+  } deriving (Eq, Show, Generic)++instance ToJSON ReceiptItem where+  toJSON = toJsonDrop 3+instance FromJSON ReceiptItem where+  parseJSON = parseJsonDrop 3 ++receiptItem :: Text -> ReceiptItem+receiptItem title = ReceiptItem title Nothing Nothing Nothing Nothing Nothing ++-- | Shipping address object for Receipt Template messages+data ShippingAddress = ShippingAddress +  { sa_street_1    :: Text       -- ^ Street Address, line 1+  , sa_street_2    :: Maybe Text -- ^ Street Address, line 2+  , sa_city        :: Text       -- ^ City+  , sa_postal_code :: Text       -- ^ Postal Code+  , sa_state       :: Text       -- ^ State abbrevation+  , sa_country     :: Text       -- ^ Two-letter country abbreviation+  } deriving (Eq, Show, Generic)++instance ToJSON ShippingAddress where+  toJSON = toJsonDrop 3+instance FromJSON ShippingAddress where+  parseJSON = parseJsonDrop 3++shippingAddress :: Text -> Text -> Text -> Text -> Text -> ShippingAddress+shippingAddress street city postalCode state country = ShippingAddress street Nothing city postalCode state country ++-- | Payment summary object for Receipt Template messages+data PaymentSummary = PaymentSummary +  { ps_subtotal      :: Maybe Double  -- ^ Subtotal+  , ps_shipping_cost :: Maybe Double  -- ^ Shipping Cost+  , ps_total_tax     :: Maybe Double  -- ^ Total Tax+  , ps_total_cost    :: Double        -- ^ Total Cost+  } deriving (Eq, Show, Generic)++instance ToJSON PaymentSummary where+  toJSON = toJsonDrop 3+instance FromJSON PaymentSummary where+  parseJSON = parseJsonDrop 3+  +paymentSummary :: Double -> PaymentSummary+paymentSummary totalCost = PaymentSummary Nothing Nothing Nothing totalCost ++data PaymentAdjustment = PaymentAdjustment+  { pa_name   :: Maybe Text     -- ^ Name of adjustment+  , pa_amount :: Maybe Double   -- ^ Adjusted amount+  } deriving (Eq, Show, Generic)++instance ToJSON PaymentAdjustment where+  toJSON = toJsonDrop 3  +instance FromJSON PaymentAdjustment where+  parseJSON = parseJsonDrop 3+++-- | This object represents a structured message request+data SendStructuredMessageRequest = SendStructuredMessageRequest+  { smRecipient         :: Recipient+  , smAttachment        :: AttachmentWrapper         +  , smNotificationType  :: Maybe NotificationType+  } deriving (Eq, Show)++instance ToJSON SendStructuredMessageRequest where+  toJSON SendStructuredMessageRequest{..} = omitNulls [ "recipient" .= smRecipient, "message" .= tw, "notification_type" .= smNotificationType ]+     where tw = object [ "attachment" .= smAttachment ]+  +instance FromJSON SendStructuredMessageRequest where+  parseJSON = withObject "send structured message" $ \o ->+    let aw = o .: "message" >>= (.: "attachment") in +      SendStructuredMessageRequest <$> o .: "recipient" <*> aw <*> o .:? "notification_type"+ +-- | Take a notification type (optional), a recipient, an image url.+--   Return a SendStructuredMessageRequest for a structured message with image attachment+sendImageMessageRequest :: Maybe NotificationType -> Recipient -> Text -> SendStructuredMessageRequest+sendImageMessageRequest notificationType recipient imgUrl = +  SendStructuredMessageRequest recipient attachment notificationType+  where attachment = ItImage $ ImagePayload imgUrl++-- | Take a notification type (optional), a recipient, a list of ButtonElement.+--   Return a SendStructuredMessageRequest for a structured message with generic template+sendGenericTemplateMessageRequest :: Maybe NotificationType -> Recipient -> [BubbleElement]  -> SendStructuredMessageRequest+sendGenericTemplateMessageRequest notificationType recipient bubbles = +  SendStructuredMessageRequest recipient attachment notificationType+  where attachment = ItGeneric $ GenericTemplate bubbles ++-- | Take a notification type (optional), a recipient, the text of the message and a list of buttons (they will appear as call-to-actions).+--   Return a SendStructuredMessageRequest for a structured message with button template+sendButtonTemplateMessageRequest :: Maybe NotificationType -> Recipient -> Text -> [Button]  -> SendStructuredMessageRequest+sendButtonTemplateMessageRequest notificationType recipient text buttons = +  SendStructuredMessageRequest recipient attachment notificationType+  where attachment = ItButton $ ButtonTemplate text buttons++-- | Take a notification type (optional), a recipient and all the informations needed to construct a ReceiptTemplate object.+--   Namely: the recipient name, the order number (must be unique), the currency, the payment method, the timestamp (optional), +--   the order url (optional), a list with the receipt items, the shipping address (optional), the payment summary and, +--   finally, a list of payment adjustments (optional).+--   Return a SendStructuredMessageRequest for a structured message with receipt template+sendReceiptTemplateMessageRequest :: Maybe NotificationType -> Recipient -> Text -> Text -> Text -> Text -> Maybe Text+                                           -> Maybe Text -> [ReceiptItem] -> Maybe ShippingAddress -> PaymentSummary -> Maybe [PaymentAdjustment]+                                           -> SendStructuredMessageRequest+sendReceiptTemplateMessageRequest notificationType recipient +  recipientName orderNumber currency paymentMethod timeStamp orderUrl items address summary adjustments = +    SendStructuredMessageRequest recipient attachment notificationType+    where +        attachment = ItReceipt $ ReceiptTemplate recipientName orderNumber currency paymentMethod timeStamp orderUrl items address summary adjustments++-- | This object represents a Welcome Message (FromJSON is disabled for it)+data WelcomeMessageRequest = +    WelcomeTextMessage        { wtmMessage :: Text } +  | WelcomeStructuredMessage  { wsmMessage :: AttachmentWrapper } +  | WelcomeEmptyMessage+  deriving (Eq, Show, Generic)+  +instance ToJSON WelcomeMessageRequest where+  toJSON mw = object [ "setting_type" .= ("call_to_actions"::String), "thread_state" .= ("new_thread"::String), "call_to_actions" .= at ]+    where at = case mw of+                  WelcomeTextMessage{..} -> [ object [ "message" .= object [ "text" .= wtmMessage ] ] ]+                  WelcomeStructuredMessage{..} -> [ object [ "message" .= wsmMessage ] ]+                  WelcomeEmptyMessage -> [ ]++--instance FromJSON WelcomeMessage where+--  parseJSON = parseJsonDrop 4 ++-- | Take a text. Return a WelcomeMessageRequest+setWelcomeTextMessageRequest :: Text -> WelcomeMessageRequest+setWelcomeTextMessageRequest = WelcomeTextMessage ++-- | Take an image url.+--   Return a WelcomeMessageRequest for a structured message with image attachment+setWelcomeImageMessageRequest :: Text -> WelcomeMessageRequest+setWelcomeImageMessageRequest imgUrl = WelcomeStructuredMessage attachment+  where attachment = ItImage $ ImagePayload imgUrl ++-- | Take a list of ButtonElement.+--   Return a WelcomeMessageRequest for a structured message with generic template+setWelcomeGenericTemplateMessageRequest :: [BubbleElement]  -> WelcomeMessageRequest+setWelcomeGenericTemplateMessageRequest bubbles = WelcomeStructuredMessage attachment+  where attachment = ItGeneric $ GenericTemplate bubbles ++-- | Take the text of the message and a list of buttons (they will appear as call-to-actions).+--   Return a WelcomeMessageRequest for a structured message with button template+setWelcomeButtonTemplateMessageRequest :: Text -> [Button]  -> WelcomeMessageRequest+setWelcomeButtonTemplateMessageRequest text buttons = WelcomeStructuredMessage attachment+  where attachment = ItButton $ ButtonTemplate text buttons+++-- The code below is partially from https://github.com/klappvisor/haskell-telegram-api/blob/master/src/Web/Telegram/API/Bot/Requests.hs+-- Code Licenseded under BSD3 - Copyright Alexey Rodiontsev (c) 2015++-- | This object represents data (image, video, ...) to upload.+data FileUploadContent =+    FileUploadFile FilePath+  | FileUploadBS BS.ByteString+  | FileUploadLBS LBS.ByteString++-- | This object represents data (image, video, ...) with mime type to upload.+data FileUpload = FileUpload+  { fileUpload_type    :: Maybe MimeType    -- ^ Mime type of the upload.+  , fileUpload_content :: FileUploadContent -- ^ The payload/source to upload.+  }++-- | Return a FileUpload from a given FilePath. +--   At the moment, only png and jpg images are supported by the API.+localFileUpload :: FilePath -> FileUpload+localFileUpload path = FileUpload+  { fileUpload_type    = Nothing+  , fileUpload_content = FileUploadFile path+  }++fileUploadToPart :: Text -> FileUpload -> Part+fileUploadToPart inputName fileUpload =+  let part =+        case fileUpload_content fileUpload of+          FileUploadFile path -> partFileSource inputName path+          FileUploadBS bs     -> partBS inputName bs+          FileUploadLBS lbs   -> partLBS inputName lbs+  in part { partContentType = fileUpload_type fileUpload }++utf8Part :: Text -> Text -> Part+utf8Part inputName = partBS inputName . T.encodeUtf8++-- | This object represents request for 'sendImage'+data UploadImageMessageRequest payload = UploadImageMessageRequest+  {+    uiRecipient                 :: Recipient        -- ^ Recipient user+  , uiFileData                  :: payload           -- ^ Photo to send. Formats supported: jpg and png.+  } deriving (Eq, Show)++instance ToJSON (UploadImageMessageRequest Text) where+  toJSON UploadImageMessageRequest{..} = object [ "recipient"  .= uiRecipient, "file_data"  .= uiFileData ]++instance FromJSON (UploadImageMessageRequest Text) where+  parseJSON = withObject "upload image message" $ \o -> do+    uiRecipient <- o .: "recipient"+    uiFileData  <- o .: "file_data"+    return UploadImageMessageRequest{..}++-- sendImageMessageRequest :: Recipient -> Text -> UploadImageMessageRequest Text+-- sendImageMessageRequest reciptient image = UploadImageMessageRequest recipient image emptyImageMessageAttachment++-- | Take a recipient and FileUpload (relative to a jpg or png). Return a (UploadImageMessageRequest FileUpload) +--   for a structured message contatining and image uploaded using multipart form data. +uploadImageMessageRequest :: Recipient -> FileUpload -> UploadImageMessageRequest FileUpload+uploadImageMessageRequest = UploadImageMessageRequest++instance ToMultipartFormData (UploadImageMessageRequest FileUpload) where+  toMultipartFormData req =+    [ partLBS "recipient" . encode $ uiRecipient req+    , partLBS "message"   $ encode $ object ["attachment" .= object ["type" .= ("image"::String), "payload" .= object [] ]]+    , fileUploadToPart "file_data" (uiFileData req) ]+++-- Helpers++-- from http://bitemyapp.com/posts/2014-07-31-aeson-with-uncertainty-revised.html+omitNulls :: [(Text, Value)] -> Value+omitNulls = object . filter notNull where+  notNull (_, Null) = False+  notNull _         = True
+ src/Web/FBMessenger/API/Bot/Responses.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeOperators              #-}++{-# OPTIONS_GHC -fno-warn-unused-binds  #-}++-- | This module contains responses from Messenger Platform Bot API+module Web.FBMessenger.API.Bot.Responses +  ( -- * Types +    MessageResponse        (..)+  , SendErrorCode          (..)+  , SendErrorObject        (..)+  , SubscriptionResponse   (..)+  , UserProfileResponse    (..)+  , WelcomeMessageResponse (..)+  -- * Functions+  , errorInfo+  , extractSendError+  ) where++import           Data.Aeson+import           Data.Text (Text)+import           GHC.Generics+import           Servant.Client (ServantError(..))+import           Web.FBMessenger.API.Bot.JsonExt+++-- | This object represents the 'subscribed_apps' success response+data SubscriptionResponse = SubscriptionResponse{ subscription_success :: Bool } deriving (Eq, Show, Generic)++instance ToJSON SubscriptionResponse where+  toJSON = toJsonDrop 13++instance FromJSON SubscriptionResponse where+  parseJSON = parseJsonDrop 13++-- | This object contais the response after a message has been succesfully sent +data MessageResponse = MessageResponse +  { message_response_recipient_id :: Text+  , message_response_message_id   :: Text+  } deriving (Eq, Show, Generic)++instance ToJSON MessageResponse where+  toJSON = toJsonDrop 17++instance FromJSON MessageResponse where+  parseJSON = parseJsonDrop 17+++-- | This objects contains the User Profile informations+data UserProfileResponse = UserProfileResponse +  { usr_first_name  :: Text+  , usr_last_name   :: Text+  , usr_profile_pic :: Text+  , usr_locale      :: Text+  , usr_timezone    :: Int+  , usr_gender      :: Text +  } deriving (Eq, Show, Generic)+  +instance ToJSON UserProfileResponse where+  toJSON = toJsonDrop 4+  +instance FromJSON UserProfileResponse where+  parseJSON = parseJsonDrop 4+++-- | This objects contains informations on the succesful setup of a welcome message+data WelcomeMessageResponse = WelcomeMessageResponse { wmr_result :: Text } deriving (Eq, Show, Generic)++instance ToJSON WelcomeMessageResponse where+  toJSON = toJsonDrop 4++instance FromJSON WelcomeMessageResponse where+  parseJSON = parseJsonDrop 4++-- | Send API Error response object (see: https://developers.facebook.com/docs/messenger-platform/send-api-reference#errors)+-- +--   {+--    "error":{+--       "message":"Invalid parameter",+--       "type":"FacebookApiException",+--       "code":100,+--       "error_data":"No matching user found.",+--       "fbtrace_id":"D2kxCybrKVw"+--    }+--  +data SendErrorObject = SendErrorObject { eoMessage :: Text, eoType :: Text, eoCode :: SendErrorCode, eoErrorData :: Text, eoFbtraceId :: Text } deriving (Eq, Show, Generic)+                           +instance ToJSON SendErrorObject where+  toJSON SendErrorObject{..} = object [ "error" .= e ]+    where e = object [ "message"    .= eoMessage+                     , "type"       .= eoType+                     , "code"       .= eoCode+                     , "error_data" .= eoErrorData+                     , "fbtrace_id" .= eoFbtraceId ]+  +instance FromJSON SendErrorObject where+  parseJSON = withObject "send error" $ \o ->+    let e = o .: "error"+        e' field = e >>= (.: field)+    in SendErrorObject <$>+       e' "message"    <*>+       e' "type"       <*>+       e' "code"       <*>+       e' "error_data" <*>+       e' "fbtrace_id"  +++-- | Send API Error Codes (see: https://developers.facebook.com/docs/messenger-platform/send-api-reference#errors)+--+--   Code	Description+--   2     Send message failure. Internal server error.+--   10    Application does not have permission to use the Send API+--   100   No matching user found+--   613   Calls to this api have exceeded the rate limit.+--+data SendErrorCode = InternalServerError | UnauthorizedApplication | NoMatchingUserFound | RateLimitError deriving (Eq, Show) +instance ToJSON SendErrorCode where+  toJSON InternalServerError     = Number 2+  toJSON UnauthorizedApplication = Number 10+  toJSON NoMatchingUserFound     = Number 100+  toJSON RateLimitError          = Number 613+instance FromJSON SendErrorCode where+  parseJSON (Number 2)   = pure InternalServerError+  parseJSON (Number 10)  = pure UnauthorizedApplication+  parseJSON (Number 100) = pure NoMatchingUserFound+  parseJSON (Number 613) = pure RateLimitError+  parseJSON _            = fail "Unable to parse SendErrorCode" +++-- | Take a Send API error object and return a tuple containing the error code and the error_data (seems to always be the description)+errorInfo :: SendErrorObject -> (SendErrorCode, Text)+errorInfo err = (ecode, edata) +  where edata = eoErrorData err+        ecode = eoCode err++-- | Extracts a Send API Error object from the ServantError (when possible).+extractSendError :: ServantError -> Maybe SendErrorObject+extractSendError FailureResponse{ responseStatus = _, responseContentType = _+                                , responseBody = body +                                } = do+                                  eo <- decode body :: Maybe SendErrorObject+                                  return eo+extractSendError _ = Nothing
+ src/Web/FBMessenger/API/Bot/SendAPI.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeOperators              #-}++module Web.FBMessenger.API.Bot.SendAPI +  ( -- * Functions+    getUserProfileInfo+  , removeWelcomeMessage+  , sendTextMessage+  , sendStructuredMessage+  , setWelcomeMessage+  , subscribedApps+  , uploadImageMessage+    -- * API+  , api+  , FBMessengerSendAPI+    -- * Types+  , Token                  (..)+  ) where+++import           Control.Monad.Trans.Except (runExceptT) -- ExceptT+import           Data.Proxy+import           Data.Text (Text)+import qualified Data.Text as T+import           Network.HTTP.Client (Manager)+import           Servant.API+import           Servant.Client+import           Servant.Client.MultipartFormData+import           Web.FBMessenger.API.Bot.Requests+import           Web.FBMessenger.API.Bot.Responses+++-- | Messenger Platform PAGE_ACCESS_TOKEN+newtype Token = Token Text+   deriving (Show, Eq, Ord, ToHttpApiData, FromHttpApiData)++-- | Type for token+-- NOTE: QueryParam here gives us a Maybe Token+type GraphAPIAccessToken = QueryParam "access_token" Token+++-- Servant.Client.BaseUrl+graphAPIBaseUrl :: BaseUrl+graphAPIBaseUrl = BaseUrl Https "graph.facebook.com" 443 "/v2.6/me"+++-- | Messenger Platform Send API+type FBMessengerSendAPI = +         GraphAPIAccessToken :> "messages" +         :> ReqBody '[JSON] SendTextMessageRequest+         :> Post '[JSON] MessageResponse+    :<|> GraphAPIAccessToken :> "messages"+         :> MultipartFormDataReqBody (UploadImageMessageRequest FileUpload)+         :> Post '[JSON] MessageResponse+    :<|> GraphAPIAccessToken :> "messages" +         :> ReqBody '[JSON] SendStructuredMessageRequest+         :> Post '[JSON] MessageResponse+    :<|> GraphAPIAccessToken :> "subscribed_apps"+         :> Post '[JSON] SubscriptionResponse+    :<|> GraphAPIAccessToken :> Capture "page_id" Text :> "thread_settings"+         :> ReqBody '[JSON] WelcomeMessageRequest+         :> Post '[JSON] WelcomeMessageResponse+    :<|> GraphAPIAccessToken :> Capture "page_id" Text :> "thread_settings"+         :> ReqBody '[JSON] WelcomeMessageRequest+         :> Delete '[JSON] WelcomeMessageResponse+    :<|> GraphAPIAccessToken :> QueryParam "fields" Text :> Capture "user_id" Text+         :> Get '[JSON] UserProfileResponse+++-- | Proxy for Messenger Platform Bot Send+api :: Proxy FBMessengerSendAPI+api = Proxy++-- type ClientM = ExceptT ServantError IO+sendTextMessage_       ::               Maybe Token -> SendTextMessageRequest -> Manager -> BaseUrl -> ClientM MessageResponse+uploadImageMessage_    :: Maybe Token -> UploadImageMessageRequest FileUpload -> Manager -> BaseUrl -> ClientM MessageResponse+sendStructuredMessage_ ::         Maybe Token -> SendStructuredMessageRequest -> Manager -> BaseUrl -> ClientM MessageResponse+subscribedApps_        ::                                         Maybe Token -> Manager -> BaseUrl -> ClientM SubscriptionResponse+welcomeMessage_        ::        Maybe Token -> Text -> WelcomeMessageRequest -> Manager -> BaseUrl -> ClientM WelcomeMessageResponse+deleteWMessage_        ::        Maybe Token -> Text -> WelcomeMessageRequest -> Manager -> BaseUrl -> ClientM WelcomeMessageResponse+userProfile_           ::                   Maybe Token -> Maybe Text -> Text -> Manager -> BaseUrl -> ClientM UserProfileResponse++sendTextMessage_+  :<|> uploadImageMessage_+  :<|> sendStructuredMessage_+  :<|> subscribedApps_ +  :<|> welcomeMessage_+  :<|> deleteWMessage_+  :<|> userProfile_ = client api+++-- | Send text messages. On success, minor informations on the sent message are returned.+sendTextMessage :: Maybe Token -> SendTextMessageRequest -> Manager -> IO (Either ServantError MessageResponse)+sendTextMessage = run graphAPIBaseUrl sendTextMessage_++-- | Upload an image and send a structured messages containing it. On success, minor informations on the sent message are returned.+uploadImageMessage :: Maybe Token -> UploadImageMessageRequest FileUpload -> Manager -> IO (Either ServantError MessageResponse)+uploadImageMessage = run graphAPIBaseUrl uploadImageMessage_++-- | Send a structured messages. This can be an image message (containing an image url) or any template message (generic, button, receipt).  +--   On success, minor informations on the sent message are returned.+sendStructuredMessage :: Maybe Token -> SendStructuredMessageRequest -> Manager -> IO (Either ServantError MessageResponse)+sendStructuredMessage = run graphAPIBaseUrl sendStructuredMessage_++-- | Test if your bot's auth token is enabled. Requires no parameters.+--   Return a simple object containing a boolean value indicating if the token is correctly registered.+subscribedApps :: Maybe Token -> Manager -> IO (Either ServantError SubscriptionResponse)+subscribedApps token manager = runExceptT $ subscribedApps_ token manager graphAPIBaseUrl++-- | Set a welcome message, this can be an image message (containing an image url) or any template message (generic, button, receipt).+--   In addition to the token and the message request, you need to provide the facebook page_id.+--   Return a simple object containing a string indicating if the welcome message is correctly registered.+setWelcomeMessage :: Maybe Token -> Text -> WelcomeMessageRequest -> Manager -> IO (Either ServantError WelcomeMessageResponse)+setWelcomeMessage token pageId message manager = runExceptT $ welcomeMessage_ token pageId message manager graphAPIBaseUrl++-- | Remove the welcome message. In addition to the token, you need to provide the facebook page_id.+--   Return a simple object containing a string indicating if the welcome message is correctly removed.+removeWelcomeMessage :: Maybe Token -> Text -> Manager -> IO (Either ServantError WelcomeMessageResponse)+removeWelcomeMessage token pageId manager = runExceptT $ deleteWMessage_ token pageId welcomeDeleteMessage manager graphAPIBaseUrl++-- | Get the profile informations of a user. In addition to the token, you need to provide the user_id.+--   Return a record containing the profile informations.+getUserProfileInfo :: Maybe Token -> Text -> Manager -> IO (Either ServantError UserProfileResponse)+getUserProfileInfo token userId manager = runExceptT $ userProfile_ token userProfileFields userId manager graphAPIBaseUrl+++-- Helpers (not exported)++userProfileFields :: Maybe Text+userProfileFields = pure $ T.pack "first_name,last_name,profile_pic,locale,timezone,gender"++welcomeDeleteMessage :: WelcomeMessageRequest+welcomeDeleteMessage = WelcomeEmptyMessage++run :: BaseUrl -> (Maybe Token -> a -> Manager -> BaseUrl -> ClientM b) -> Maybe Token -> a -> Manager -> IO (Either ServantError b)+run b e t r m = runExceptT $ e t r m b
+ src/Web/FBMessenger/API/Bot/WebhookAPI.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeOperators              #-}++module Web.FBMessenger.API.Bot.WebhookAPI (+      RemoteEvent                      (..)+    , RemoteEventList                  (..)+    , EventMessage                     (..)+    , EventMessageContent              (..) +    , EventMessageAttachment           (..)+    , EventMessageAttachmentType       (..)+) where+    +import           Control.Monad (when)+import           Data.Aeson+import           Data.HashMap.Lazy (member)+import           Data.Text (Text)+import           GHC.Generics+import           Web.FBMessenger.API.Bot.JsonExt++-- TODOS: * add docstrings+--        * try to cleanup and simplify the API and the data representation +--        * consider adding useful getters and a mapper from [RemoteEvents] -> [EventMessage]++data RemoteEventList = RemoteEventList [RemoteEvent] deriving (Eq, Show)+instance ToJSON RemoteEventList where+    toJSON (RemoteEventList evts) = object [ "object" .= ("page"::String), "entry" .= evts ]+instance FromJSON RemoteEventList where+    parseJSON = withObject "webhook request" $ \o -> do+                  obj <- o .: "object"+                  when (obj /= ("page"::String)) $ +                    fail "invalid messaging event request"+                  evts <- o .: "entry"+                  return (RemoteEventList evts)+++data RemoteEvent = RemoteEvent+    { evt_id        :: Int              -- ^ Page ID of page +    , evt_time      :: Int              -- ^ Time of update+    , evt_messaging :: [EventMessage]   -- ^ Array containing objects related to messaging+    } deriving (Show, Eq, Generic)++instance ToJSON RemoteEvent where+    toJSON = toJsonDrop 4+instance FromJSON RemoteEvent where+    parseJSON = parseJsonDrop 4+++data EventMessage = EventMessage +    { evtSenderId    :: Text            -- ^ Sender user ID+    , evtRecipientId :: Text            -- ^ Recipient user ID+    , evtTimestamp   :: Maybe Int+    , evtContent     :: EventMessageContent+    } deriving (Show, Eq)++instance ToJSON EventMessage where +    toJSON EventMessage{..} = +        let content = case evtContent of +                        EmTextMessage{}       -> "message"+                        EmStructuredMessage{} -> "message"+                        EmAuth{}              -> "optin"+                        EmDelivery{}          -> "delivery"+                        EmPostback{}          -> "postback"+        in omitNulls [ "sender"    .= object [ "id" .= evtSenderId ]+                     , "recipient" .= object [ "id" .= evtRecipientId ] +                     , "timestamp" .= evtTimestamp+                     , content     .= evtContent ]+                            +instance FromJSON EventMessage where+    parseJSON = withObject "WebSocket message content" $ \o -> do+                  evtSenderId    <- o .: "sender" >>= (.: "id")+                  evtRecipientId <- o .: "recipient" >>= (.: "id")+                  evtTimestamp   <- o .:? "timestamp"+                  -- not too clean but seems to do the job+                  -- if we refactor, it's faster if we get the first true only+                  let evtChoices = filter (`member` o) (["message", "optin", "delivery", "postback"]::[Text])+                  when (null evtChoices) $ +                    fail "unknown message content"+                  -- WARN: here I am assuming only one kind of content per request+                  evtContent <- o .: head evtChoices +                  return EventMessage{..}+++data EventMessageContent = EmTextMessage Text Int Text       -- ^ Message ID; Message sequence number; Message text. +                         | EmStructuredMessage Text Int [EventMessageAttachment] -- ^ Message ID; Message sequence number; Array containing attachment data (image, video, audio)+                         | EmAuth Text                       -- ^ data-ref parameter that was defined with the entry point+                         | EmDelivery Int Int (Maybe [Text]) -- ^ Sequence No.; Watermark: all messages that were sent before this timestamp were delivered; Array containing message IDs of messages that were delivered (optional) +                         | EmPostback Text                   -- ^ Contains the postback payload that was defined with the button+                         deriving (Show, Eq)+instance ToJSON EventMessageContent where+    toJSON (EmTextMessage mid seq text) = object [ "mid" .= mid, "seq" .= seq, "text" .= text ] +    toJSON (EmStructuredMessage mid seq attachments) = object [ "mid" .= mid, "seq" .= seq, "attachments" .= attachments ]+    toJSON (EmAuth ref) = object [ "ref" .= ref ]+    toJSON (EmDelivery seq watermark mids) = omitNulls [ "seq" .= seq, "watermark" .= watermark, "mids" .= mids ]+    toJSON (EmPostback payload) = object [ "payload" .= payload ]+    +instance FromJSON EventMessageContent where+    parseJSON = withObject "message content" $ \o -> do+        let ctChoices = filter (`member` o) (["text", "attachments", "ref", "watermark", "payload"]::[Text])+        when (null ctChoices) $ +            fail "unknown message content"+        case head ctChoices of+            "text"        -> EmTextMessage <$> o .: "mid" <*> o .: "seq" <*> o .: "text"+            "attachments" -> EmStructuredMessage <$> o .: "mid"  <*> o .: "seq" <*> o .: "attachments"+            "ref"         -> EmAuth <$> o .: "ref"+            "watermark"   -> EmDelivery <$> o .: "seq" <*> o .: "watermark" <*> o .:? "mids"+            "payload"     -> EmPostback <$> o .: "payload"+            _             -> error "this cannot happen by construction, but I want to make the compiler happy"+++data EventMessageAttachment = EmAttachment { emType :: EventMessageAttachmentType, emUrl :: Text } deriving (Show, Eq)+instance ToJSON EventMessageAttachment where+    toJSON EmAttachment{..} = object [ "type" .= emType, "payload" .= object [ "url" .= emUrl ] ]+instance FromJSON EventMessageAttachment where+    parseJSON = withObject "websocket call message attachment" $ \o -> do+        emType <- o .: "type"+        emUrl  <- o .: "payload" >>= (.: "url")+        return EmAttachment{..} +    +data EventMessageAttachmentType = EmImage | EmVideo | EmAudio deriving (Show, Eq)+instance ToJSON EventMessageAttachmentType where+    toJSON EmImage = "image"+    toJSON EmVideo = "video"+    toJSON EmAudio = "audio" +instance FromJSON EventMessageAttachmentType where+    parseJSON "image" = pure EmImage+    parseJSON "video" = pure EmVideo+    parseJSON "audio" = pure EmAudio+    parseJSON _       = fail "impossible to parse AttachmentType"+    +++-- Helpers++-- from http://bitemyapp.com/posts/2014-07-31-aeson-with-uncertainty-revised.html+omitNulls :: [(Text, Value)] -> Value+omitNulls = object . filter notNull where+  notNull (_, Null) = False+  notNull _         = True
+ test-files/buttonTemplate.json view
@@ -0,0 +1,26 @@+{+  "recipient":{+    "id":"USER_ID"+  },+  "message":{+    "attachment":{+      "type":"template",+      "payload":{+        "template_type":"button",+        "text":"What do you want to do next?",+        "buttons":[+          {+            "type":"web_url",+            "url":"https://petersapparel.parseapp.com",+            "title":"Show Website"+          },+          {+            "type":"postback",+            "title":"Start Chatting",+            "payload":"USER_DEFINED_PAYLOAD"+          }+        ]+      }+    }+  }+}
+ test-files/deleteWelcomeMessage.json view
@@ -0,0 +1,5 @@+{+  "setting_type":"call_to_actions",+  "thread_state":"new_thread",+  "call_to_actions":[]+}
+ test-files/errorResponse.json view
@@ -0,0 +1,9 @@+{+   "error":{+      "message":"Invalid parameter",+      "type":"FacebookApiException",+      "code":100,+      "error_data":"No matching user found.",+      "fbtrace_id":"D2kxCybrKVw"+   }+}
+ test-files/genericTemplate.json view
@@ -0,0 +1,59 @@+{+  "recipient":{+    "id":"USER_ID"+  },+  "message":{+    "attachment":{+      "type":"template",+      "payload":{+        "template_type":"generic",+        "elements":[+          {+            "title":"Classic White T-Shirt",+            "image_url":"http://petersapparel.parseapp.com/img/item100-thumb.png",+            "subtitle":"Soft white cotton t-shirt is back in style",+            "buttons":[+              {+                "type":"web_url",+                "url":"https://petersapparel.parseapp.com/view_item?item_id=100",+                "title":"View Item"+              },+              {+                "type":"web_url",+                "url":"https://petersapparel.parseapp.com/buy_item?item_id=100",+                "title":"Buy Item"+              },+              {+                "type":"postback",+                "title":"Bookmark Item",+                "payload":"USER_DEFINED_PAYLOAD_FOR_ITEM100"+              }              +            ]+          },+          {+            "title":"Classic Grey T-Shirt",+            "image_url":"http://petersapparel.parseapp.com/img/item101-thumb.png",+            "subtitle":"Soft gray cotton t-shirt is back in style",+            "buttons":[+              {+                "type":"web_url",+                "url":"https://petersapparel.parseapp.com/view_item?item_id=101",+                "title":"View Item"+              },+              {+                "type":"web_url",+                "url":"https://petersapparel.parseapp.com/buy_item?item_id=101",+                "title":"Buy Item"+              },+              {+                "type":"postback",+                "title":"Bookmark Item",+                "payload":"USER_DEFINED_PAYLOAD_FOR_ITEM101"+              }              +            ]+          }+        ]+      }+    }+  }+}
+ test-files/imageMessage.json view
@@ -0,0 +1,13 @@+{+  "recipient":{+    "id":"USER_ID"+  },+  "message":{+    "attachment":{+      "type":"image",+      "payload":{+        "url":"https://petersapparel.com/img/shirt.png"+      }+    }+  }+}
+ test-files/messageResponse.json view
@@ -0,0 +1,4 @@+{+  "recipient_id": "1008372609250235",+  "message_id": "mid.1456970487936:c34767dfe57ee6e339"+}
+ test-files/receiptTemplate.json view
@@ -0,0 +1,61 @@+{+  "recipient":{+    "id":"USER_ID"+  },+  "message":{+    "attachment":{+      "type":"template",+      "payload":{+        "template_type":"receipt",+        "recipient_name":"Stephane Crozatier",+        "order_number":"12345678902",+        "currency":"USD",+        "payment_method":"Visa 2345",        +        "order_url":"http://petersapparel.parseapp.com/order?order_id=123456",+        "timestamp":"1428444852", +        "elements":[+          {+            "title":"Classic White T-Shirt",+            "subtitle":"100% Soft and Luxurious Cotton",+            "quantity":2,+            "price":50,+            "currency":"USD",+            "image_url":"http://petersapparel.parseapp.com/img/whiteshirt.png"+          },+          {+            "title":"Classic Gray T-Shirt",+            "subtitle":"100% Soft and Luxurious Cotton",+            "quantity":1,+            "price":25,+            "currency":"USD",+            "image_url":"http://petersapparel.parseapp.com/img/grayshirt.png"+          }+        ],+        "address":{+          "street_1":"1 Hacker Way",+          "street_2":"",+          "city":"Menlo Park",+          "postal_code":"94025",+          "state":"CA",+          "country":"US"+        },+        "summary":{+          "subtotal":75.00,+          "shipping_cost":4.95,+          "total_tax":6.19,+          "total_cost":56.14+        },+        "adjustments":[+          {+            "name":"New Customer Discount",+            "amount":20+          },+          {+            "name":"$10 Off Coupon",+            "amount":10+          }+        ]+      }+    }+  }+}
+ test-files/subscriptionResponse.json view
@@ -0,0 +1,3 @@+{+  "success": true+}
+ test-files/textMessage.json view
@@ -0,0 +1,8 @@+{+    "recipient":{+        "id":"USER_ID"+    }, +    "message":{+        "text":"hello, world!"+    }+}
+ test-files/userProfileInfoResponse.json view
@@ -0,0 +1,8 @@+{+  "first_name": "Peter",+  "last_name": "Chang",+  "profile_pic": "https://fbcdn-profile-a.akamaihd.net/hprofile-ak-xpf1/v/t1.0-1/p200x200/13055603_10105219398495383_8237637584159975445_n.jpg?oh=1d241d4b6d4dac50eaf9bb73288ea192&oe=57AF5C03&__gda__=1470213755_ab17c8c8e3a0a447fed3f272fa2179ce",+  "locale": "en_US",+  "timezone": -7,+  "gender": "male"+}
+ test-files/welcomeMessageResponse.json view
@@ -0,0 +1,3 @@+{+  "result": "Successfully added new_thread's CTAs"+}
+ test-files/welcomeStructuredMessage.json view
@@ -0,0 +1,36 @@+{+  "setting_type":"call_to_actions",+  "thread_state":"new_thread",+  "call_to_actions":[+    {+      "message":{+        "attachment":{+          "type":"template",+          "payload":{+            "template_type":"generic",+            "elements":[+              {+                "title":"Welcome to My Company!",+                "item_url":"https://www.petersbowlerhats.com",+                "image_url":"https://www.petersbowlerhats.com/img/hat.jpeg",+                "subtitle":"We have the right hat for everyone.",+                "buttons":[+                  {+                    "type":"web_url",+                    "title":"View Website",+                    "url":"https://www.petersbowlerhats.com"+                  },+                  {+                    "type":"postback",+                    "title":"Start Chatting",+                    "payload":"DEVELOPER_DEFINED_PAYLOAD"+                  }+                ]+              }+            ]+          }+        }+      }+    }+  ]+}
+ test-files/welcomeTextMessage.json view
@@ -0,0 +1,11 @@+{+  "setting_type":"call_to_actions",+  "thread_state":"new_thread",+  "call_to_actions":[+    {+      "message":{+        "text":"Welcome to My Company!"+      }+    }+  ]+}
+ test-files/wsAuthRequest.json view
@@ -0,0 +1,23 @@+{+  "object":"page",+  "entry":[+    {+      "id":111111,+      "time":12341,+      "messaging":[+        {+          "sender":{+            "id":"USER_ID"+          },+          "recipient":{+            "id":"PAGE_ID"+          },+          "timestamp":1234567890,+          "optin":{+            "ref":"PASS_THROUGH_PARAM"+          }+        }+      ]+    }+  ]+}
+ test-files/wsDeliveryRequest.json view
@@ -0,0 +1,26 @@+{+   "object":"page",+   "entry":[+      {+         "id":111111,+         "time":1458668856451,+         "messaging":[+            {+               "sender":{+                  "id":"USER_ID"+               },+               "recipient":{+                  "id":"PAGE_ID"+               },+               "delivery":{+                  "mids":[+                     "mid.1458668856218:ed81099e15d3f4f233"+                  ],+                  "watermark":1458668856253,+                  "seq":37+               }+            }+         ]+      }+   ]+}
+ test-files/wsPostbackRequest.json view
@@ -0,0 +1,23 @@+{+  "object":"page",+  "entry":[+    {+      "id":111111,+      "time":1458692752478,+      "messaging":[+        {+          "sender":{+            "id":"USER_ID"+          },+          "recipient":{+            "id":"PAGE_ID"+          },+          "timestamp":1458692752478,+          "postback":{+            "payload":"USER_DEFINED_PAYLOAD"+          }+        }+      ]+    }+  ]+}
+ test-files/wsStructuredMessageRequest.json view
@@ -0,0 +1,32 @@+{+  "object":"page",+  "entry":[+    {+      "id":111111,+      "time":1458696618911,+      "messaging":[+        {+          "sender":{+            "id":"USER_ID"+          },+          "recipient":{+            "id":"PAGE_ID"+          },+          "timestamp":1458696618268,+          "message":{+            "mid":"mid.1458696618141:b4ef9d19ec21086067",+            "seq":51,+            "attachments":[+              {+                "type":"image",+                "payload":{+                  "url":"IMAGE_URL"+                }+              }+            ]+          }+        }+      ]+    }+  ]+}
+ test-files/wsTextMessageRequest.json view
@@ -0,0 +1,25 @@+{+  "object":"page",+  "entry":[+    {+      "id":111111,+      "time":1457764198246,+      "messaging":[+        {+          "sender":{+            "id":"USER_ID"+          },+          "recipient":{+            "id":"PAGE_ID"+          },+          "timestamp":1457764197627,+          "message":{+            "mid":"mid.1457764197618:41d102a3e1ae206a38",+            "seq":73,+            "text":"hello, world!"+          }+        }+      ]+    }+  ]+}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}