module Web.FBMessenger.API.Bot.Requests
(
Button (..)
, BubbleElement (..)
, FileUpload (..)
, FileUploadContent (..)
, NotificationType (..)
, PaymentSummary (..)
, PaymentAdjustment (..)
, Recipient (..)
, ReceiptItem (..)
, ShippingAddress (..)
, SendTextMessageRequest (..)
, SendStructuredMessageRequest (..)
, UploadImageMessageRequest (..)
, WelcomeMessageRequest (..)
, 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 Servant.Client.MultipartFormData (ToMultipartFormData (..))
import Web.FBMessenger.API.Bot.JsonExt
data Recipient = Recipient
{ recipient_id :: Maybe Text
, recipient_phone_number :: Maybe Text
} deriving (Eq, Show, Generic)
instance ToJSON Recipient where
toJSON = toJsonDrop 10
instance FromJSON Recipient where
parseJSON = parseJsonDrop 10
recipient :: Maybe Text -> Maybe Text -> Maybe Recipient
recipient Nothing Nothing = Nothing
recipient (Just _) (Just _) = Nothing
recipient rid phone_number = pure $ Recipient rid phone_number
data NotificationType = Regular
| SilentPush
| NoPush
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"
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"
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"
data ImagePayload = ImagePayload
{ imgUrl :: Text
} deriving (Eq, Show)
parseImagePayload :: Object -> Parser ImagePayload
parseImagePayload v = ImagePayload <$> v.: "url"
data GenericTemplate = GenericTemplate
{ genElements :: [BubbleElement]
} deriving (Eq, Show)
parseGenericTemplate :: Object -> Parser GenericTemplate
parseGenericTemplate v = GenericTemplate <$> v .: "elements"
data ButtonTemplate = ButtonTemplate
{ btnText :: Text
, btnButtons :: [Button]
} deriving (Eq, Show)
parseButtonTemplate :: Object -> Parser ButtonTemplate
parseButtonTemplate v = ButtonTemplate <$> v .: "text" <*> v .: "buttons"
data ReceiptTemplate = ReceiptTemplate
{ rcpRecipientName :: Text
, rcpOrderNumber :: Text
, rcpCurrency :: Text
, rcpPaymentMethod :: Text
, rcpTimestamp :: Maybe Text
, rcpOrderUrl :: Maybe Text
, rcpElements :: [ReceiptItem]
, rcpAddress :: Maybe ShippingAddress
, rcpSummary :: PaymentSummary
, rcpAdjustments :: Maybe [PaymentAdjustment]
} 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"
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"
data Button = Button
{ btn_type :: ButtonType
, btn_title :: Text
, btn_url :: Maybe Text
, btn_payload :: Maybe Text
} deriving (Eq, Show, Generic)
instance ToJSON Button where
toJSON = toJsonDrop 4
instance FromJSON Button where
parseJSON = parseJsonDrop 4
webUrlButton :: Text -> Text -> Button
webUrlButton title url = Button WebUrl title (Just url) Nothing
postbackButton :: Text -> Text -> Button
postbackButton title payload = Button Postback title Nothing (Just payload)
data BubbleElement = BubbleElement
{ elm_title :: Text
, elm_item_url :: Maybe Text
, elm_image_url :: Maybe Text
, elm_subtitle :: Maybe Text
, elm_buttons :: Maybe [Button]
} deriving (Eq, Show, Generic)
instance ToJSON BubbleElement where
toJSON = toJsonDrop 4
instance FromJSON BubbleElement where
parseJSON = parseJsonDrop 4
bubbleElement :: Text -> BubbleElement
bubbleElement title = BubbleElement title Nothing Nothing Nothing Nothing
data ReceiptItem = ReceiptItem
{ re_title :: Text
, re_subtitle :: Maybe Text
, re_quantity :: Maybe Int
, re_price :: Maybe Int
, re_currency :: Maybe Text
, re_image_url :: Maybe Text
} 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
data ShippingAddress = ShippingAddress
{ sa_street_1 :: Text
, sa_street_2 :: Maybe Text
, sa_city :: Text
, sa_postal_code :: Text
, sa_state :: Text
, sa_country :: Text
} 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
data PaymentSummary = PaymentSummary
{ ps_subtotal :: Maybe Double
, ps_shipping_cost :: Maybe Double
, ps_total_tax :: Maybe Double
, ps_total_cost :: Double
} 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
, pa_amount :: Maybe Double
} deriving (Eq, Show, Generic)
instance ToJSON PaymentAdjustment where
toJSON = toJsonDrop 3
instance FromJSON PaymentAdjustment where
parseJSON = parseJsonDrop 3
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"
sendImageMessageRequest :: Maybe NotificationType -> Recipient -> Text -> SendStructuredMessageRequest
sendImageMessageRequest notificationType recipient imgUrl =
SendStructuredMessageRequest recipient attachment notificationType
where attachment = ItImage $ ImagePayload imgUrl
sendGenericTemplateMessageRequest :: Maybe NotificationType -> Recipient -> [BubbleElement] -> SendStructuredMessageRequest
sendGenericTemplateMessageRequest notificationType recipient bubbles =
SendStructuredMessageRequest recipient attachment notificationType
where attachment = ItGeneric $ GenericTemplate bubbles
sendButtonTemplateMessageRequest :: Maybe NotificationType -> Recipient -> Text -> [Button] -> SendStructuredMessageRequest
sendButtonTemplateMessageRequest notificationType recipient text buttons =
SendStructuredMessageRequest recipient attachment notificationType
where attachment = ItButton $ ButtonTemplate text buttons
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
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 -> [ ]
setWelcomeTextMessageRequest :: Text -> WelcomeMessageRequest
setWelcomeTextMessageRequest = WelcomeTextMessage
setWelcomeImageMessageRequest :: Text -> WelcomeMessageRequest
setWelcomeImageMessageRequest imgUrl = WelcomeStructuredMessage attachment
where attachment = ItImage $ ImagePayload imgUrl
setWelcomeGenericTemplateMessageRequest :: [BubbleElement] -> WelcomeMessageRequest
setWelcomeGenericTemplateMessageRequest bubbles = WelcomeStructuredMessage attachment
where attachment = ItGeneric $ GenericTemplate bubbles
setWelcomeButtonTemplateMessageRequest :: Text -> [Button] -> WelcomeMessageRequest
setWelcomeButtonTemplateMessageRequest text buttons = WelcomeStructuredMessage attachment
where attachment = ItButton $ ButtonTemplate text buttons
data FileUploadContent =
FileUploadFile FilePath
| FileUploadBS BS.ByteString
| FileUploadLBS LBS.ByteString
data FileUpload = FileUpload
{ fileUpload_type :: Maybe MimeType
, fileUpload_content :: FileUploadContent
}
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
data UploadImageMessageRequest payload = UploadImageMessageRequest
{
uiRecipient :: Recipient
, uiFileData :: payload
} 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{..}
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) ]
omitNulls :: [(Text, Value)] -> Value
omitNulls = object . filter notNull where
notNull (_, Null) = False
notNull _ = True