diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/example-app/example.hs b/example-app/example.hs new file mode 100644 --- /dev/null +++ b/example-app/example.hs @@ -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 diff --git a/fbmessenger-api.cabal b/fbmessenger-api.cabal new file mode 100644 --- /dev/null +++ b/fbmessenger-api.cabal @@ -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 diff --git a/src/Servant/Client/MultipartFormData.hs b/src/Servant/Client/MultipartFormData.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/MultipartFormData.hs @@ -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) diff --git a/src/Web/FBMessenger/API/Bot.hs b/src/Web/FBMessenger/API/Bot.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot.hs @@ -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 diff --git a/src/Web/FBMessenger/API/Bot/JsonExt.hs b/src/Web/FBMessenger/API/Bot/JsonExt.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot/JsonExt.hs @@ -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 } + diff --git a/src/Web/FBMessenger/API/Bot/Requests.hs b/src/Web/FBMessenger/API/Bot/Requests.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot/Requests.hs @@ -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 diff --git a/src/Web/FBMessenger/API/Bot/Responses.hs b/src/Web/FBMessenger/API/Bot/Responses.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot/Responses.hs @@ -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 diff --git a/src/Web/FBMessenger/API/Bot/SendAPI.hs b/src/Web/FBMessenger/API/Bot/SendAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot/SendAPI.hs @@ -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 diff --git a/src/Web/FBMessenger/API/Bot/WebhookAPI.hs b/src/Web/FBMessenger/API/Bot/WebhookAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/FBMessenger/API/Bot/WebhookAPI.hs @@ -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 diff --git a/test-files/buttonTemplate.json b/test-files/buttonTemplate.json new file mode 100644 --- /dev/null +++ b/test-files/buttonTemplate.json @@ -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" + } + ] + } + } + } +} diff --git a/test-files/deleteWelcomeMessage.json b/test-files/deleteWelcomeMessage.json new file mode 100644 --- /dev/null +++ b/test-files/deleteWelcomeMessage.json @@ -0,0 +1,5 @@ +{ + "setting_type":"call_to_actions", + "thread_state":"new_thread", + "call_to_actions":[] +} diff --git a/test-files/errorResponse.json b/test-files/errorResponse.json new file mode 100644 --- /dev/null +++ b/test-files/errorResponse.json @@ -0,0 +1,9 @@ +{ + "error":{ + "message":"Invalid parameter", + "type":"FacebookApiException", + "code":100, + "error_data":"No matching user found.", + "fbtrace_id":"D2kxCybrKVw" + } +} diff --git a/test-files/genericTemplate.json b/test-files/genericTemplate.json new file mode 100644 --- /dev/null +++ b/test-files/genericTemplate.json @@ -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" + } + ] + } + ] + } + } + } +} diff --git a/test-files/imageMessage.json b/test-files/imageMessage.json new file mode 100644 --- /dev/null +++ b/test-files/imageMessage.json @@ -0,0 +1,13 @@ +{ + "recipient":{ + "id":"USER_ID" + }, + "message":{ + "attachment":{ + "type":"image", + "payload":{ + "url":"https://petersapparel.com/img/shirt.png" + } + } + } +} diff --git a/test-files/messageResponse.json b/test-files/messageResponse.json new file mode 100644 --- /dev/null +++ b/test-files/messageResponse.json @@ -0,0 +1,4 @@ +{ + "recipient_id": "1008372609250235", + "message_id": "mid.1456970487936:c34767dfe57ee6e339" +} diff --git a/test-files/receiptTemplate.json b/test-files/receiptTemplate.json new file mode 100644 --- /dev/null +++ b/test-files/receiptTemplate.json @@ -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 + } + ] + } + } + } +} diff --git a/test-files/subscriptionResponse.json b/test-files/subscriptionResponse.json new file mode 100644 --- /dev/null +++ b/test-files/subscriptionResponse.json @@ -0,0 +1,3 @@ +{ + "success": true +} diff --git a/test-files/textMessage.json b/test-files/textMessage.json new file mode 100644 --- /dev/null +++ b/test-files/textMessage.json @@ -0,0 +1,8 @@ +{ + "recipient":{ + "id":"USER_ID" + }, + "message":{ + "text":"hello, world!" + } +} diff --git a/test-files/userProfileInfoResponse.json b/test-files/userProfileInfoResponse.json new file mode 100644 --- /dev/null +++ b/test-files/userProfileInfoResponse.json @@ -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" +} diff --git a/test-files/welcomeMessageResponse.json b/test-files/welcomeMessageResponse.json new file mode 100644 --- /dev/null +++ b/test-files/welcomeMessageResponse.json @@ -0,0 +1,3 @@ +{ + "result": "Successfully added new_thread's CTAs" +} diff --git a/test-files/welcomeStructuredMessage.json b/test-files/welcomeStructuredMessage.json new file mode 100644 --- /dev/null +++ b/test-files/welcomeStructuredMessage.json @@ -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" + } + ] + } + ] + } + } + } + } + ] +} diff --git a/test-files/welcomeTextMessage.json b/test-files/welcomeTextMessage.json new file mode 100644 --- /dev/null +++ b/test-files/welcomeTextMessage.json @@ -0,0 +1,11 @@ +{ + "setting_type":"call_to_actions", + "thread_state":"new_thread", + "call_to_actions":[ + { + "message":{ + "text":"Welcome to My Company!" + } + } + ] +} diff --git a/test-files/wsAuthRequest.json b/test-files/wsAuthRequest.json new file mode 100644 --- /dev/null +++ b/test-files/wsAuthRequest.json @@ -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" + } + } + ] + } + ] +} diff --git a/test-files/wsDeliveryRequest.json b/test-files/wsDeliveryRequest.json new file mode 100644 --- /dev/null +++ b/test-files/wsDeliveryRequest.json @@ -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 + } + } + ] + } + ] +} diff --git a/test-files/wsPostbackRequest.json b/test-files/wsPostbackRequest.json new file mode 100644 --- /dev/null +++ b/test-files/wsPostbackRequest.json @@ -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" + } + } + ] + } + ] +} diff --git a/test-files/wsStructuredMessageRequest.json b/test-files/wsStructuredMessageRequest.json new file mode 100644 --- /dev/null +++ b/test-files/wsStructuredMessageRequest.json @@ -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" + } + } + ] + } + } + ] + } + ] +} diff --git a/test-files/wsTextMessageRequest.json b/test-files/wsTextMessageRequest.json new file mode 100644 --- /dev/null +++ b/test-files/wsTextMessageRequest.json @@ -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!" + } + } + ] + } + ] +} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}