dialogflow-fulfillment (empty) → 0.1.0.0
raw patch · 16 files changed
+1514/−0 lines, 16 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, dialogflow-fulfillment, directory, hspec, hspec-discover, text, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- dialogflow-fulfillment.cabal +78/−0
- src/Dialogflow/Util.hs +35/−0
- src/Dialogflow/V2/Fulfillment/Message.hs +403/−0
- src/Dialogflow/V2/Fulfillment/Payload/Google.hs +400/−0
- src/Dialogflow/V2/Fulfillment/Webhook/Request.hs +151/−0
- src/Dialogflow/V2/Fulfillment/Webhook/Response.hs +79/−0
- test/Dialogflow/V2/Fulfillment/MessageSpec.hs +122/−0
- test/Dialogflow/V2/Fulfillment/Payload/GoogleSpec.hs +102/−0
- test/Dialogflow/V2/Fulfillment/Webhook/RequestSpec.hs +46/−0
- test/Dialogflow/V2/Fulfillment/Webhook/ResponseSpec.hs +23/−0
- test/Spec.hs +1/−0
- test/TestUtil.hs +32/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for dialogflow-fulfillment++## 0.1.0.0 -- 2019-09-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Mauricio Fierro++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 Mauricio Fierro 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.
+ README.md view
@@ -0,0 +1,5 @@+[](https://travis-ci.org/mauriciofierrom/dialogflow-fulfillment)++# dialogflow-fulfillment++A basic library to create responses for Google's Dialogflow fulfilment webhooks.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dialogflow-fulfillment.cabal view
@@ -0,0 +1,78 @@+cabal-version: 2.4+name: dialogflow-fulfillment+version: 0.1.0.0+tested-with: GHC==8.6.4+category: API+synopsis: A Dialogflow Fulfillment library for Haskell.+description:+ A library to create responses for Google's Dialogflow fulfillment webhook.+ .+ Dialogflow is an end-to-end, build-once deploy-everywhere development suite+ for creating conversational interfaces for websites, mobile applications,+ popular messaging platforms, and IoT devices. Find more at the Google Cloud+ <https://cloud.google.com/dialogflow/ site for the project>.+ .+ Check how fulfillment works in the Dialogflow+ <https://cloud.google.com/dialogflow/docs/fulfillment-how documentation>.++homepage: https://github.com/mauriciofierrom/dialogflow-fulfillment+bug-reports: https://github.com/mauriciofierrom/dialogflow-fulfillment/issues+license: BSD-3-Clause+license-file: LICENSE+author: Mauricio Fierro+maintainer: mauriciofierrom@gmail.com+copyright: (c) 2019 Mauricio Fierro+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mauriciofierrom/dialogflow-fulfillment++library+ exposed-modules:+ Dialogflow.V2.Fulfillment.Message+ Dialogflow.V2.Fulfillment.Payload.Google+ Dialogflow.V2.Fulfillment.Webhook.Request+ Dialogflow.V2.Fulfillment.Webhook.Response+ other-modules:+ Dialogflow.Util++ build-depends:+ aeson >= 1.4.2 && < 1.5+ , base ^>=4.12.0.0+ , bytestring >= 0.10.8 && < 0.11+ , containers >= 0.6.0 && < 0.7+ , text >= 1.2.3 && < 1.3+ , unordered-containers >= 0.2.10 && < 0.3++ hs-source-dirs: src++ default-language: Haskell2010+ ghc-options: -Wall++test-suite dialogflow-fulfillment-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tools: hspec-discover+ other-modules:+ TestUtil+ Dialogflow.V2.Fulfillment.MessageSpec+ Dialogflow.V2.Fulfillment.Payload.GoogleSpec+ Dialogflow.V2.Fulfillment.Webhook.RequestSpec+ Dialogflow.V2.Fulfillment.Webhook.ResponseSpec+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , aeson-pretty >= 0.8.7 && < 0.9+ , base+ , bytestring+ , containers+ , dialogflow-fulfillment+ , directory >= 1.3.3 && < 1.4+ , hspec >= 2.7.1 && < 2.8+ , hspec-discover >= 2.7.1 && < 2.8+ default-language: Haskell2010
+ src/Dialogflow/Util.hs view
@@ -0,0 +1,35 @@+{-|+Module : Dialogflow.Util+Description : Utilities+Copyright : (c) Mauricio Fierro, 2019+License : BSD3-Clause+Maintainer : Mauricio Fierro <mauriciofierrom@gmail.com>++This module contains misc utility functions.+-}++module Dialogflow.Util+ ( toObject+ , noNullObjects+ ) where++import Data.Aeson ( ToJSON+ , toJSON+ , object+ , Value(..)+ , Object )+import Data.Aeson.Types (Pair)++-- | Turn a value into an aeson @Object@+toObject :: ToJSON a => a -> Object+toObject a = case toJSON a of+ Object o -> o+ _ -> error "toObject: value isn't an Object"++{-|+ Removes values that were parsed to @Null@ values.+ Useful to avoid having @null@ values in generated+ JSON for @Nothing@ values.+-}+noNullObjects :: [Pair] -> Value+noNullObjects = object . filter (\(_,v) -> v /= Null)
+ src/Dialogflow/V2/Fulfillment/Message.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++{-|+Module : Dialogflow.V2.Util+Description : Dialogflow types for response messages.+Copyright : (c) Mauricio Fierro, 2019+License : BSD3-Clause+Maintainer : Mauricio Fierro <mauriciofierrom@gmail.com>++This module contains types for Dialogflow messages to be used in+a fulfillment webhook response. See the Dialogflow <https://cloud.google.com/dialogflow/docs/reference/rpc/google.cloud.dialogflow.v2#google.cloud.dialogflow.v2.Intent.Message documentation>.+-}++module Dialogflow.V2.Fulfillment.Message+ ( CardButton(..)+ , BasicCardContent(..)+ , BasicCardButton(..)+ , Item(..)+ , OpenUriAction(..)+ , SpeechText(..)+ , SimpleResponse(..)+ , Suggestion(..)+ , SelectItemInfo(..)+ , MsgType(..)+ , Msg( Text+ , Image+ , QuickReplies+ , Card+ , SimpleResponses+ , BasicCard+ , Suggestions+ , LinkOutSuggestion+ , ListSelect+ , CarouselSelect+ )+ , Message(..)+ ) where++import Data.Aeson ( FromJSON+ , parseJSON+ , ToJSON+ , toJSON+ , Value(..)+ , withObject+ , (.:)+ , (.:!)+ , (.=))+import Data.Foldable (asum)++import qualified Data.HashMap.Strict as HM++import Dialogflow.Util++-- | Button for a 'Card' message+data CardButton = CardButton+ { cbText :: Maybe String -- ^ The text to show on the button.+ , cbPostback :: Maybe String -- ^ The text to send to the Dialogflow API or URI to open.+ } deriving (Eq, Show)++instance FromJSON CardButton where+ parseJSON = withObject "cardButton" $ \cb -> do+ cbText <- cb .:! "text"+ cbPostback <- cb .:! "postback"+ return CardButton{..}++instance ToJSON CardButton where+ toJSON CardButton{..} =+ noNullObjects [ "text" .= cbText+ , "postback" .= cbPostback ]++-- | The 'BasicCard' message can have either an 'Image' or+-- formatted text as content.+data BasicCardContent = BasicCardImage (Msg 'MsgImage)+ | BasicCardFormattedText String+ deriving (Eq, Show)++instance FromJSON BasicCardContent where+ parseJSON = withObject "Image or formatted text" $ \bcc ->+ asum [ BasicCardImage <$> bcc .: "image"+ , BasicCardFormattedText <$> bcc .: "formatted_text" ]++instance ToJSON BasicCardContent where+ toJSON = \case+ BasicCardImage image -> noNullObjects [ "image" .= image ]+ BasicCardFormattedText formattedText -> noNullObjects [ "formatted_text" .= formattedText ]++-- | A 'SimpleResponse' can have text-to-speech in plain text+-- or SSML format.+data SpeechText = TextToSpeech String -- ^ The plain text of the speech output+ | SSML String -- ^ Structured spoken response to the user in SSML format+ deriving (Eq, Show)++instance FromJSON SpeechText where+ parseJSON = withObject "textToSpeech or SSML" $ \st ->+ asum [ TextToSpeech <$> st .: "textToSpeech"+ , SSML <$> st .: "ssml" ]++instance ToJSON SpeechText where+ toJSON = \case+ TextToSpeech textToSpeech -> noNullObjects ["textToSpeech" .= textToSpeech]+ SSML ssml -> noNullObjects ["ssml" .= ssml]++-- | A simple response message containing speech or text+data SimpleResponse = SimpleResponse+ { simpleResponseText :: SpeechText -- ^ The speech text+ , displayText :: Maybe String -- ^ The text to display+ } deriving (Eq, Show)++instance FromJSON SimpleResponse where+ parseJSON = withObject "simpleResponse" $ \sr -> do+ simpleResponseText <- parseJSON (Object sr)+ displayText <- sr .:! "displayText"+ return SimpleResponse{..}++instance ToJSON SimpleResponse where+ toJSON SimpleResponse{..} = Object $+ toObject simpleResponseText <> HM.fromList ["displayText" .= displayText ]++-- | An action to open the given URI. Used in 'BasicCardButton's.+newtype OpenUriAction = OpenUriAction+ { unOpenUriAction :: String -- ^ The HTTP or HTTPS scheme URI+ } deriving (Eq, Show)++instance ToJSON OpenUriAction where+ toJSON oua = noNullObjects [ "uri" .= unOpenUriAction oua ]++instance FromJSON OpenUriAction where+ parseJSON = withObject "openUriAction" $ \oua -> do+ uri <- oua .: "uri"+ return $ OpenUriAction uri++-- | Buttons for 'BasicCard's.+data BasicCardButton = BasicCardButton+ { bcbTitle :: String -- ^ The title of the button+ , bcbOpenUriAction :: OpenUriAction -- ^ Action to take when a user taps on the button+ } deriving (Eq, Show)++instance FromJSON BasicCardButton where+ parseJSON = withObject "basicCardButton" $ \bcb -> do+ bcbTitle <- bcb .: "title"+ bcbOpenUriAction <- bcb .: "open_uri_action"+ return BasicCardButton{..}++instance ToJSON BasicCardButton where+ toJSON BasicCardButton{..} =+ noNullObjects [ "title" .= bcbTitle+ , "open_uri_action" .= bcbOpenUriAction ]++-- | Suggestion chips.+newtype Suggestion = Suggestion+ { unSuggestionTitle :: String -- ^ The text shown in the suggestion chip+ } deriving (Eq, Show)++instance FromJSON Suggestion where+ parseJSON = withObject "suggestion" $ \s -> do+ unSuggestionTitle <- s .: "title"+ return $ Suggestion unSuggestionTitle++instance ToJSON Suggestion where+ toJSON s =+ noNullObjects [ "title" .= unSuggestionTitle s ]++-- | Additional information about an 'Item' for when it is triggered in a dialog.+data SelectItemInfo = SelectItemInfo+ { siiKey :: String+ -- ^ A unique key that will be sent back to the agent if this response is given.+ , siiSynonyms :: Maybe [String]+ -- ^ A list of synonyms that can also be used to trigger this item in dialog.+ } deriving (Eq, Show)++instance FromJSON SelectItemInfo where+ parseJSON = withObject "selectedItemInfo" $ \sii -> do+ siiKey <- sii .: "key"+ siiSynonyms <- sii .: "synonyms"+ return SelectItemInfo{..}++instance ToJSON SelectItemInfo where+ toJSON SelectItemInfo{..} =+ noNullObjects [ "key" .= siiKey+ , "synonyms" .= siiSynonyms ]++-- | The possible types of 'Message'.+data MsgType = MsgText+ | MsgImage+ | MsgQuickReplies+ | MsgCard+ | MsgSimpleResponses+ | MsgBasicCard+ | MsgSuggestions+ | MsgLinkOutSuggestion+ | MsgListSelect+ | MsgCarouselSelect++-- | The messages to be included in the Response.+data Msg t where+ -- | The text response message.+ Text+ :: Maybe [String] -- ^ The collection of the agent's responses+ -> Msg 'MsgText++ -- | The image response message.+ Image+ :: String -- ^ The public URI to an image file+ -> Maybe String -- ^ A text description of the image to be used for accessibility+ -> Msg 'MsgImage++ -- | The quick replies response message.+ QuickReplies+ :: Maybe String -- ^ The title of the collection of quick replies+ -> [String] -- ^ The collection of quick replies+ -> Msg 'MsgQuickReplies++ -- | The card response.+ Card+ :: Maybe String -- ^ The title of the card+ -> Maybe String -- ^ The subtitle of the card+ -> Maybe String -- ^ The public URI to an image file for the card+ -> Maybe [CardButton] -- ^ The collection of card buttons+ -> Msg 'MsgCard++ -- | The collection of 'SimpleResponse' candidates.+ SimpleResponses+ :: [SimpleResponse] -- ^ The list of simple responses+ -> Msg 'MsgSimpleResponses++-- TODO: Check if the formattedText and image fields are mutually exclusive+ -- | The basic card message. Useful for displaying information.+ BasicCard+ :: Maybe String -- ^ The title of the card+ -> Maybe String -- ^ The subtitle of the card+ -> BasicCardContent -- ^ The body text or image of the card+ -> Maybe [BasicCardButton] -- ^ The collection of card buttons+ -> Msg 'MsgBasicCard++ -- | The collection of 'Suggestion'.+ Suggestions+ :: [Suggestion] -- ^ The list of suggested replies+ -> Msg 'MsgSuggestions++ -- | The suggestion chip message that allows the user to jump+ -- out to the app or the website associated with this agent.+ LinkOutSuggestion+ :: String -- ^ The name of the app or site this chip is linking to+ -> String -- ^ The URI of the app or site to open when the user taps the suggestion chip+ -> Msg 'MsgLinkOutSuggestion++ -- | The card for presenting a list of options to select from.+ ListSelect+ :: Maybe String -- ^ The overall title of the list+ -> [Item] -- ^ List items+ -> Msg 'MsgListSelect++ -- | The card for representing a carousel of options to select from.+ CarouselSelect+ :: [Item] -- ^ Carousel items+ -> Msg 'MsgCarouselSelect++deriving instance Show (Msg t)+deriving instance Eq (Msg t)++instance FromJSON (Msg 'MsgImage) where+ parseJSON = withObject "image" $ \i -> do+ uri <- i .: "image_uri"+ allyText <- i .:! "accessibility_text"+ return (Image uri allyText)++instance FromJSON (Msg 'MsgText) where+ parseJSON = withObject "text" $ \t -> do+ text <- t .: "text"+ return $ Text text++instance FromJSON (Msg 'MsgQuickReplies) where+ parseJSON = withObject "quickReplies" $ \qr -> do+ title <- qr .:! "title"+ replies <- qr .: "quick_replies"+ return $ QuickReplies title replies++instance FromJSON (Msg 'MsgCard) where+ parseJSON = withObject "card" $ \card -> do+ c <- card .: "card"+ mbTitle <- c .:! "title"+ mbSubtitle <- c .:! "subtitle"+ mbUri <- c .:! "image_uri"+ cardButtons <- c .:! "buttons"+ return $ Card mbTitle mbSubtitle mbUri cardButtons++instance FromJSON (Msg 'MsgSimpleResponses) where+ parseJSON = withObject "simpleResponses" $ \sr -> do+ srs <- sr .: "simpleResponses"+ responses <- srs .: "simpleResponses"+ return $ SimpleResponses responses++instance FromJSON (Msg 'MsgBasicCard) where+ parseJSON = withObject "basicCard" $ \bc -> do+ mbTitle <- bc .:! "title"+ mbSubtitle <- bc .:! "subtitle"+ content <- parseJSON (Object bc)+ buttons <- bc .:! "buttons"+ return $ BasicCard mbTitle mbSubtitle content buttons++instance FromJSON (Msg 'MsgSuggestions) where+ parseJSON = withObject "suggestions" $ \sgs -> do+ suggestions <- sgs .: "suggestions"+ return $ Suggestions suggestions++instance FromJSON (Msg 'MsgLinkOutSuggestion) where+ parseJSON = withObject "linkOutSuggestion" $ \los -> do+ uri <- los .: "uri"+ destinationName <- los .: "destination_name"+ return $ LinkOutSuggestion destinationName uri++instance FromJSON (Msg 'MsgListSelect) where+ parseJSON = withObject "listSelect" $ \ls -> do+ title <- ls .:! "title"+ items <- ls .: "items"+ return $ ListSelect title items++instance FromJSON (Msg 'MsgCarouselSelect) where+ parseJSON = withObject "carouselSelect" $ \cs -> do+ items <- cs .: "items"+ return $ CarouselSelect items++instance ToJSON (Msg t) where+ toJSON (Text mbText) = noNullObjects [ "text" .= mbText ]+ toJSON (Image uri accesibilityText) =+ noNullObjects [ "image_uri" .= uri+ , "accessibility_text" .= accesibilityText ]+ toJSON (QuickReplies mbTitle quickReplies) =+ noNullObjects [ "title" .= mbTitle+ , "quick_replies" .= quickReplies ]+ toJSON (Card title subtitle imageUri buttons) =+ noNullObjects [ "card" .= noNullObjects ["title" .= title+ , "subtitle" .= subtitle+ , "image_uri" .= imageUri+ , "buttons" .= buttons ] ]+ toJSON (SimpleResponses simpleResponses) =+ noNullObjects [ "simpleResponses" .= noNullObjects ["simpleResponses" .= simpleResponses ] ]+ toJSON (BasicCard mbTitle mbSubtitle content buttons) =+ Object $ HM.fromList [ "title" .= mbTitle+ , "subtitle" .= mbSubtitle+ , "buttons" .= buttons ] <> toObject content+ toJSON (Suggestions xs) = noNullObjects [ "suggestions" .= xs ]+ toJSON (LinkOutSuggestion name uri) =+ noNullObjects [ "destination_name" .= name, "uri" .= uri ]+ toJSON (ListSelect mbTitle items) =+ noNullObjects [ "title" .= mbTitle+ , "items" .= items ]+ toJSON (CarouselSelect items) = noNullObjects [ "items" .= items ]++-- | This type is used to wrap the messages under one type.+data Message where+ Message :: (Show (Msg t)) => Msg t -> Message++instance Show Message where+ show (Message o) = show o++instance ToJSON Message where+ toJSON (Message bc@BasicCard{}) = noNullObjects [ "basicCard" .= toJSON bc ]+ toJSON (Message o) = toJSON o++instance Eq Message where+ (==) (Message x@Text{}) (Message y@Text{}) = x == y+ (==) (Message x@Image{}) (Message y@Image{}) = x == y+ (==) (Message x@QuickReplies{}) (Message y@QuickReplies{}) = x == y+ (==) (Message x@Card{}) (Message y@Card{}) = x == y+ (==) (Message x@SimpleResponses{}) (Message y@SimpleResponses{}) = x == y+ (==) (Message x@BasicCard{}) (Message y@BasicCard{}) = x == y+ (==) (Message x@Suggestions{}) (Message y@Suggestions{}) = x == y+ (==) (Message x@LinkOutSuggestion{}) (Message y@LinkOutSuggestion{}) = x == y+ (==) (Message x@ListSelect{}) (Message y@ListSelect{}) = x == y+ (==) (Message x@CarouselSelect{}) (Message y@CarouselSelect{}) = x == y+ (==) _ _ = False++-- | An item in 'ListSelect' and 'CarouselSelect'.+data Item = Item+ { iInfo :: SelectItemInfo -- ^ Additional information about this option+ , iTitle :: String -- ^ The title of the list item+ , iDescription :: Maybe String -- ^ The main text describing the item+ , iImage :: Msg 'MsgImage -- ^ The image to display+ } deriving (Eq, Show)++instance FromJSON Item where+ parseJSON = withObject "Item" $ \i -> do+ iInfo <- i .: "info"+ iTitle <- i .: "title"+ iDescription <- i .:! "description"+ iImage <- i .: "image"+ return Item{..}++instance ToJSON Item where+ toJSON Item{..} =+ noNullObjects [ "info" .= iInfo+ , "title" .= iTitle+ , "description" .= iDescription+ , "image" .= iImage ]
+ src/Dialogflow/V2/Fulfillment/Payload/Google.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++{-|+Module : Dialogflow.V2.Payload.Google+Description : Dialogflow types for Google Actions payload.+Copyright : (c) Mauricio Fierro, 2019+License : BSD3-Clause+Maintainer : Mauricio Fierro <mauriciofierrom@gmail.com>++This module contains types for the Google Actions payload to be included+in the webhook reponse. See the Dialogflow <https://developers.google.com/actions/build/json/dialogflow-webhook-json#dialogflow-response-body documentation>.+-}++module Dialogflow.V2.Fulfillment.Payload.Google where++import Data.Aeson ( parseJSON+ , toJSON+ , withObject+ , FromJSON+ , ToJSON+ , Value(..)+ , (.=)+ , (.:)+ , (.:!) )+import Data.Foldable (asum)+import qualified Data.HashMap.Strict as HM++import Dialogflow.Util+import qualified Dialogflow.V2.Fulfillment.Message as M++-- | This field can be used to provide responses for different platforms+-- like Actions on Google.+newtype GooglePayload =+ GooglePayload { unGooglePayload :: Response } deriving (Eq, Show)++instance ToJSON GooglePayload where+ toJSON gp =+ noNullObjects [ "google" .= unGooglePayload gp]++-- | An image.+data Image =+ Image { iUrl :: String+ , iAccessibilityText :: String+ , iHeight :: Maybe Int+ , iWidth :: Maybe Int+ } deriving (Eq, Show)++instance FromJSON Image where+ parseJSON = withObject "image" $ \i -> do+ iUrl <- i .: "url"+ iAccessibilityText <- i .: "accessibilityText"+ iHeight <- i .:! "height"+ iWidth <- i .:! "width"+ return Image{..}++instance ToJSON Image where+ toJSON Image{..} =+ noNullObjects [ "url" .= iUrl+ , "accessibilityText" .= iAccessibilityText+ , "height" .= iHeight+ , "width" .= iWidth ]++-- | A 'BasicCard' can either contain an image or formatted text.+data BasicCardContent = BasicCardImage Image+ | BasicCardFormattedText String+ deriving (Eq, Show)++instance FromJSON BasicCardContent where+ parseJSON = withObject "Image or formatted text" $ \bcc ->+ asum [ BasicCardImage <$> bcc .: "image"+ , BasicCardFormattedText <$> bcc .: "formattedText" ]++instance ToJSON BasicCardContent where+ toJSON = \case+ BasicCardImage image -> noNullObjects [ "image" .= image ]+ BasicCardFormattedText formattedText -> noNullObjects [ "formattedText" .= formattedText ]++-- | Possible image display options for affecting the presentation of an 'Image'.+-- This should be used for when the 'Image''s aspect ratio does not match the 'Image'+-- container's aspect ratio.+data ImageDisplayOption = DEFAULT+ -- ^ Fill the gaps between the 'Image' and the 'Image' container+ -- with gray bars.+ | WHITE+ -- ^ Fill the gaps between the 'Image' and the 'Image' container+ -- with white bars.+ | CROPPED+ -- ^ 'Image' is scaled such that the 'Image' width and height match+ -- or exceed the container dimensions. This may crop the top and+ -- bottom of the 'Image' if the scaled 'Image' height is greater than+ -- the container height, or crop the left and right of the 'Image'+ -- if the scaled 'Image' width is greater than the container width.+ -- This is similar to "Zoom Mode" on a widescreen TV when playing+ -- a 4:3 video.+ deriving (Eq, Read, Show)++instance FromJSON ImageDisplayOption where+ parseJSON = withObject "imageDisplayOption" $ \x -> do+ ido <- x .: "imageDisplayOptions"+ return $ read ido++instance ToJSON ImageDisplayOption where+ toJSON x = noNullObjects [ "imageDisplayOptions" .= show x ]++-- | The type of the media within the response.+data MediaType = MEDIA_TYPE_UNSPECIFIED -- ^ Unspecified.+ | AUDIO -- ^ Audio stream.+ deriving (Eq, Read, Show)++instance FromJSON MediaType where+ parseJSON = withObject "mediaType" $ \x -> do+ mt <- x .: "mediaType"+ return $ read mt++instance ToJSON MediaType where+ toJSON x = noNullObjects [ "mediaType" .= show x ]++-- | Represents one media noNullObjects which is returned with 'MediaResponse'.+-- Contains information about the media, such as name, description, url, etc.+data MediaObject =+ MediaObject { moName :: String+ -- ^ Name of the 'MediaObject'.+ , moDescription :: String+ -- ^ Description of the 'MediaObject'.+ , moContentUrl :: String+ -- ^ The url pointing to the media content.+ , moLargeImage :: Image+ -- ^ A large 'Image', such as the cover of the album, etc.+ , moIcon :: Image+ -- ^ A small 'Image' icon displayed on the right from the title.+ -- It's resized to 36x36 dp.+ } deriving (Eq, Show)++instance FromJSON MediaObject where+ parseJSON = withObject "MediaObject" $ \mo -> do+ moName <- mo .: "name"+ moDescription <- mo .: "description"+ moContentUrl <- mo .: "contentUrl"+ moLargeImage <- mo .: "largeImage"+ moIcon <- mo .: "icon"+ return MediaObject{..}++instance ToJSON MediaObject where+ toJSON MediaObject{..} =+ noNullObjects [ "name" .= moName+ , "description" .= moDescription+ , "contentUrl" .= moContentUrl+ , "largeImage" .= moLargeImage+ , "icon" .= moIcon ]++-- | The possible types of @RichMessage@s.+data RichMessageType = RMTSimpleResponse+ | RMTBasicCard+ | RMTMediaResponse++-- | The response items.+data Res t where+ -- | A simple response containing speech or text to show the user.+ SimpleResponse :: M.SimpleResponse -> Res 'RMTSimpleResponse++ -- | A basic card for displaying some information, e.g. an image and/or text.+ BasicCard :: Maybe String -- ^ Title.+ -> Maybe String -- ^ Subtitle.+ -> BasicCardContent -- ^ Card content can be an image of formatted text.+ -> [M.BasicCardButton] -- ^ Buttons. Currently supports at most 1.+ -> ImageDisplayOption -- ^ Type of display option.+ -> Res 'RMTBasicCard++ -- | The response indicating a set of media to be played within the conversation.+ MediaResponse :: MediaType -- ^ Type of the media within this response.+ -> [MediaObject] -- ^ The list of 'MediaObject's.+ -> Res 'RMTMediaResponse++deriving instance Eq (Res t)+deriving instance Show (Res t)++instance FromJSON (Res 'RMTSimpleResponse) where+ parseJSON = withObject "simpleResponse" $ \sr -> do+ simpleResponse <- sr .: "simpleResponse"+ return $ SimpleResponse simpleResponse++instance FromJSON (Res 'RMTBasicCard) where+ parseJSON = withObject "basicCard" $ \basicCard -> do+ bc <- basicCard .: "basicCard"+ mbTitle <- bc .:! "title"+ mbSubtitle <- bc .: "subtitle"+ content <- parseJSON (Object bc)+ buttons <- bc .: "buttons"+ imageDisplayOption <- parseJSON (Object bc)+ return $ BasicCard mbTitle mbSubtitle content buttons imageDisplayOption++instance FromJSON (Res 'RMTMediaResponse) where+ parseJSON = withObject "mediaResponse" $ \mediaResponse -> do+ mr <- mediaResponse .: "mediaResponse"+ mediaType <- parseJSON (Object mr)+ mediaObjects <- mr .: "mediaObjects"+ return $ MediaResponse mediaType mediaObjects++instance ToJSON (Res t) where+ toJSON (SimpleResponse s) = noNullObjects [ "simpleResponse" .= s ]+ toJSON (BasicCard t s c b d) =+ noNullObjects [ "basicCard" .= obj ]+ where+ obj = Object $ HM.fromList [ "title" .= t+ , "subtitle" .= s+ , "buttons" .= b ] <> toObject c <> toObject d+ toJSON (MediaResponse mediaType mos) =+ noNullObjects [ "mediaResponse" .= obj ]+ where+ obj = Object $ HM.fromList [ "mediaObjects" .= mos ] <> toObject mediaType++-- | The items to include in the 'RichResponse'+data Item where+ Item :: (Show (Res t)) => Res t -> Item++instance Eq Item where+ (==) (Item x@BasicCard{}) (Item y@BasicCard{}) = x == y+ (==) (Item x@SimpleResponse{}) (Item y@SimpleResponse{}) = x == y+ (==) (Item x@MediaResponse{}) (Item y@MediaResponse{}) = x == y+ (==) _ _ = False++instance ToJSON Item where+ toJSON (Item x) = toJSON x++deriving instance Show Item++-- | A rich response that can include audio, text, cards, suggestions+-- and structured data.+data RichResponse = RichResponse+ { items :: [Item]+ -- ^ A list of UI elements which compose the response. The items must meet+ -- the following requirements:+ -- 1. The first item must be a 'SimpleResponse'+ -- 2. At most two 'SimpleResponse'+ -- 3. At most one rich response item (e.g. 'BasicCard', 'StructuredResponse',+ -- 'MediaResponse', or HtmlResponse)+ -- 4. You cannot use a rich response item if you're using an actions.intent.OPTION+ -- intent ie ListSelect or CarouselSelect+ , suggestions :: [Suggestion]+ -- ^ A list of suggested replies. These will always appear at the end of the response.+ , linkOutSuggestion :: Maybe LinkOutSuggestion+ -- ^ An additional suggestion chip that can link out to the associated app+ -- or site.+ } deriving (Eq, Show)++instance ToJSON RichResponse where+ toJSON RichResponse{..} =+ noNullObjects [ "items" .= items+ , "suggestions" .= suggestions+ , "linkOutSuggestion" .= linkOutSuggestion ]++-- | The response sent by the fulfillment to Google Assistant.+data Response =+ Response { expectUserResponse :: Bool+ -- ^ Indicates whether your fulfillment expects a user response.+ -- Set the value to true when to keep the conversation going and+ -- false to end the conversation.+ , userStorage :: Maybe String+ -- ^ Stores persistent data tied to a specific user. The total storage+ -- amount is 10,000 bytes.+ , richResponse :: RichResponse+ -- ^ This field contains audio, text, cards, suggestions, or structured+ -- data for the Assistant to render. To learn more about using rich+ -- responses for Actions on Google, see 'Res'.+ } deriving (Eq, Show)++instance ToJSON Response where+ toJSON Response{..} =+ noNullObjects [ "expectUserResponse" .= expectUserResponse+ , "userStorage" .= userStorage+ , "richResponse" .= richResponse ]++-- | Different types of url hints.+data UrlTypeHint = URL_TYPE_HINT_UNSPECIFIED+ -- ^ Unspecified.+ | AMP_CONTENT+ -- ^ URL that points directly to AMP content, or to a canonical+ -- URL which refers to AMP content via .+ deriving (Eq, Read, Show)++instance FromJSON UrlTypeHint where+ parseJSON = withObject "urlTypeHint" $ \x -> do+ uth <- x .: "urlTypeHint"+ return $ read uth++instance ToJSON UrlTypeHint where+ toJSON x = noNullObjects [ "urlTypeHint" .= show x ]++-- | VersionFilter should be included if specific version/s of the App are+-- required.+data VersionFilter = VersionFilter+ { minVersion :: Int+ -- ^ Min version code or 0, inclusive.+ , maxVersion :: Int+ -- ^ Max version code, inclusive. The range considered is [minVersion:maxVersion].+ -- A null range implies any version.+ } deriving (Eq, Read, Show)++instance FromJSON VersionFilter where+ parseJSON = withObject "versionFilter" $ \vf -> do+ minVersion <- vf .: "minVersion"+ maxVersion <- vf .: "maxVersion"+ return VersionFilter{..}++instance ToJSON VersionFilter where+ toJSON VersionFilter{..} =+ noNullObjects [ "minVersion" .= minVersion+ , "maxVersion" .= maxVersion ]++-- | Specification of the Android App for fulfillment restrictions.+data AndroidApp = AndroidApp+ { aaPackageName :: String+ -- ^ Package name must be specified when specifing Android Fulfillment.+ , aaVersions :: [VersionFilter]+ -- ^ When multiple filters are specified, any filter match will trigger the app.+ } deriving (Eq, Read, Show)++instance FromJSON AndroidApp where+ parseJSON = withObject "androidApp" $ \aa -> do+ aaPackageName <- aa .: "packageName"+ aaVersions <- aa .: "versions"+ return AndroidApp{..}++instance ToJSON AndroidApp where+ toJSON AndroidApp{..} =+ noNullObjects [ "packageName" .= aaPackageName+ , "versions" .= aaVersions ]++-- | Opens the given url.+data OpenUrlAction =+ OpenUrlAction { ouaUrl :: String+ -- ^ The url field which could be any of: - http/https urls+ -- for opening an App-linked App or a webpage.+ , ouaAndroidApp :: AndroidApp+ -- ^ Information about the Android App if the URL is expected+ -- to be fulfilled by an Android App.+ , ouaUrlTypeHint :: UrlTypeHint+ -- ^ Indicates a hint for the url type.+ } deriving (Eq, Read, Show)++instance FromJSON OpenUrlAction where+ parseJSON = withObject "openUrlAction" $ \oua -> do+ ouaUrl <- oua .: "url"+ ouaAndroidApp <- oua .: "androidApp"+ ouaUrlTypeHint <- parseJSON (Object oua)+ return OpenUrlAction{..}++instance ToJSON OpenUrlAction where+ toJSON OpenUrlAction{..} =+ Object $ HM.fromList [ "url" .= ouaUrl+ , "androidApp" .= ouaAndroidApp+ ] <> toObject ouaUrlTypeHint++-- | Creates a suggestion chip that allows the user to jump out to the App+-- or Website associated with this agent.+data LinkOutSuggestion = LinkOutSuggestion+ { losDestinationName :: String+ -- ^ The name of the app or site this chip is linking to. The chip will be+ -- rendered with the title "Open ". Max 20 chars.+ , losUrl :: String+ -- ^ Deprecated. Use OpenUrlAction instead.+ , losOpenUrlAction :: OpenUrlAction+ -- ^ The URL of the App or Site to open when the user taps the suggestion+ -- chip. Ownership of this App/URL must be validated in the actions on Google+ -- developer console, or the suggestion will not be shown to the user.+ } deriving (Eq, Show)++instance FromJSON LinkOutSuggestion where+ parseJSON = withObject "linkOutSuggestion" $ \los -> do+ losDestinationName <- los .: "destinationName"+ losUrl <- los .: "url"+ losOpenUrlAction <- los .: "openUrlAction"+ return LinkOutSuggestion{..}++instance ToJSON LinkOutSuggestion where+ toJSON LinkOutSuggestion{..} =+ noNullObjects [ "destinationName" .= losDestinationName+ , "url" .= losUrl+ , "openUrlAction" .= losOpenUrlAction ]++-- | A suggestion chip that the user can tap to quickly post a reply to+-- the conversation.+newtype Suggestion = Suggestion { unSuggestion :: String }+ deriving (Eq, Show)++instance FromJSON Suggestion where+ parseJSON = withObject "suggestion" $ \s -> do+ suggestion <- s .: "title"+ return $ Suggestion suggestion++instance ToJSON Suggestion where+ toJSON s = noNullObjects [ "title" .= unSuggestion s ]
+ src/Dialogflow/V2/Fulfillment/Webhook/Request.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module : Dialogflow.V2.Request+Description : Dialogflow types for the webhook request.+Copyright : (c) Mauricio Fierro, 2019+License : BSD3-Clause+Maintainer : Mauricio Fierro <mauriciofierrom@gmail.com>++This module contains types for Dialogflow webhook requests. See the Dialogflow <https://cloud.google.com/dialogflow/docs/reference/rpc/google.cloud.dialogflow.v2#webhookrequest documentation>.+-}++module Dialogflow.V2.Fulfillment.Webhook.Request where++import Data.Aeson ( FromJSON+ , parseJSON+ , ToJSON+ , toJSON+ , withObject+ , (.:)+ , (.:!)+ , (.=))++import qualified Data.Map as M++import Dialogflow.Util++-- | Represents an intent.+data Intent =+ Intent { intentName :: String -- ^ Intent name.+ , displayName :: String -- ^ Display name for the intent.+ } deriving (Eq, Show)++instance FromJSON Intent where+ parseJSON = withObject "intent" $ \i -> do+ intentName <- i .: "name"+ displayName <- i .: "displayName"+ return Intent {..}++instance ToJSON Intent where+ toJSON Intent{..} =+ noNullObjects [ "name" .= intentName+ , "displayName" .= displayName ]++-- | Represents a context.+data Context =+ Context { ctxName :: String+ -- ^ The unique identifier of the context.+ , ctxLifespanCount :: Maybe Int+ -- ^ The number of conversational query requests after which the+ -- context expires.+ , ctxParameters :: Maybe (M.Map String String)+ -- ^ The collection of parameters associated with this context.+ } deriving (Eq, Show)++instance FromJSON Context where+ parseJSON = withObject "context" $ \c -> do+ ctxName <- c .: "name"+ ctxLifespanCount <- c .:! "lifespanCount"+ ctxParameters <- c .: "parameters"+ return Context{..}++instance ToJSON Context where+ toJSON Context{..} =+ noNullObjects [ "name" .= ctxName+ , "lifespanCount" .= ctxLifespanCount+ , "parameters" .= ctxParameters ]++-- | Represents the result of conversational query or event processing.+data QueryResult =+ QueryResult { queryText :: String+ -- ^ The original text of the query.+ , parameters :: M.Map String String+ -- ^ Consists of parameter_name:parameter_value pairs.+ , allRequiredParamsPresent :: Bool+ -- ^ Set to false if required parameters are missing in query.+ , fulfillmentText :: Maybe String+ -- ^ Text to be pronounced to the user or shown on the screen.+ , outputContexts :: Maybe [Context]+ -- ^ Collection of output contexts.+ , intent :: Maybe Intent+ -- ^ The intent that matched the user's query.+ , intentDetectionConfidence :: Maybe Float+ -- ^ Matching score for the intent.+ , diagnosticInfo :: Maybe (M.Map String String)+ -- ^ Free-form diagnostic info.+ , languageCode :: String+ -- ^ The language that was triggered during intent matching.+ } deriving (Eq, Show)++instance FromJSON QueryResult where+ parseJSON = withObject "queryResult" $ \qr -> do+ queryText <- qr .: "queryText"+ parameters <- qr .: "parameters"+ allRequiredParamsPresent <- qr .: "allRequiredParamsPresent"+ fulfillmentText <- qr .:! "fulfillmentText"+ outputContexts <- qr .:! "outputContexts"+ intent <- qr .:! "intent"+ intentDetectionConfidence <- qr .:! "intentDetectionConfidence"+ diagnosticInfo <- qr .:! "diagnosticInfo"+ languageCode <- qr .: "languageCode"+ return QueryResult{..}++instance ToJSON QueryResult where+ toJSON QueryResult{..} =+ noNullObjects [ "queryText" .= queryText+ , "parameters" .= parameters+ , "allRequiredParamsPresent" .= allRequiredParamsPresent+ , "fulfillmentText" .= fulfillmentText+ , "outputContexts" .= outputContexts+ , "intent" .= intent+ , "intentDetectionConfidence" .= intentDetectionConfidence+ , "diagnosticInfo" .= diagnosticInfo+ , "languageCode" .= languageCode ]++-- | The request message for a webhook call.+data WebhookRequest =+ WebhookRequest { responseId :: String+ -- ^ Unique id for request.+ , session :: String+ -- ^ Unique session id.+ , queryResult :: QueryResult+ -- ^ Result of the conversation query or event processing.+ } deriving(Eq, Show)++instance FromJSON WebhookRequest where+ parseJSON = withObject "webhookRequest" $ \wr -> do+ responseId <- wr .: "responseId"+ session <- wr .: "session"+ queryResult <- wr .: "queryResult"+ return WebhookRequest{..}++instance ToJSON WebhookRequest where+ toJSON WebhookRequest{..} =+ noNullObjects [ "responseId" .= responseId+ , "session" .= session+ , "queryResult" .= queryResult ]++-- TODO: Check if it's possible to have multiple Contexts with the same name+-- or if there's an use-case for that, and update accordingly.+-- | Given a list of 'Context', find the value of a parameter of a context in+-- the list.+getContextParameter :: [Context] -- ^ The list of 'Context'.+ -> String -- ^ The name of the 'Context'.+ -> String -- ^ The name of the parameter.+ -> Maybe String+getContextParameter ctxs ctx param =+ case filter (\Context{..} -> ctxName == ctx) ctxs of+ (x:_) -> M.lookup param =<< ctxParameters x+ [] -> Nothing
+ src/Dialogflow/V2/Fulfillment/Webhook/Response.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module : Dialogflow.Util+Description : Dialogflow types for the webhook response.+Copyright : (c) Mauricio Fierro, 2019+License : BSD3-Clause+Maintainer : Mauricio Fierro <mauriciofierrom@gmail.com>++This module contains types for Dialogflow webhook response. See the Dialogflow <https://cloud.google.com/dialogflow/docs/reference/rpc/google.cloud.dialogflow.v2#webhookresponse documentation>.+-}++module Dialogflow.V2.Fulfillment.Webhook.Response where++import Data.Aeson ( parseJSON+ , toJSON+ , withObject+ , FromJSON+ , ToJSON+ , (.:)+ , (.=) )+import Dialogflow.Util (noNullObjects)++import qualified Data.Map as M++import Dialogflow.V2.Fulfillment.Webhook.Request (Context)+import Dialogflow.V2.Fulfillment.Message++import qualified Dialogflow.V2.Fulfillment.Payload.Google as G++-- TODO: When this is included, no messages or payload is taken into account.+-- We gotta cover this.+-- | Makes the platform immediately invoke another DetectIntent call internally+-- with the specified event as input. When this field is set, Dialogflow ignores+-- the fulfillment_text, fulfillment_messages, and payload fields.+data EventInput =+ EventInput { eventInputName :: String+ , eventInputParameters :: Maybe (M.Map String String)+ , eventInputLanguageCode :: String+ } deriving (Eq, Show)++instance FromJSON EventInput where+ parseJSON = withObject "eventInput" $ \ei -> do+ eventInputName <- ei .: "name"+ eventInputParameters <- ei .: "parameters"+ eventInputLanguageCode <- ei .: "language_code"+ return EventInput{..}++instance ToJSON EventInput where+ toJSON EventInput{..} =+ noNullObjects [ "name" .= eventInputName+ , "parameters" .= eventInputParameters+ , "language_code" .= eventInputLanguageCode ]++-- | The response message for a webhook call.+data WebhookResponse = WebhookResponse+ { fulfillmentText :: Maybe String+ -- ^ The text to be shown on the screen+ , fulfillmentMessages :: Maybe [Message]+ -- ^ The collection of rich messages to present to the user+ , source :: Maybe String+ -- ^ The webhook source+ , payload :: Maybe G.GooglePayload+ -- ^ Webhook payload+ , outputContexts :: Maybe [Context]+ -- ^ The collection of output contexts+ , followupEventInput :: Maybe EventInput+ -- ^ Makes the platform immediately invoke another sessions+ } deriving (Eq, Show)++instance ToJSON WebhookResponse where+ toJSON WebhookResponse{..} =+ noNullObjects [ "fulfillmentText" .= fulfillmentText+ , "fulfillmentMessages" .= fulfillmentMessages+ , "source" .= source+ , "payload" .= payload+ , "outputContexts" .= outputContexts+ , "followupEventInput" .= followupEventInput ]
+ test/Dialogflow/V2/Fulfillment/MessageSpec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}++module Dialogflow.V2.Fulfillment.MessageSpec where++import Test.Hspec+import TestUtil++import Dialogflow.V2.Fulfillment.Message++basePath :: FilePath+basePath = "files/message/"++messagePath :: FilePath -> FilePath+messagePath = (<>) basePath++spec :: Spec+spec = beforeAll (prepareDirs basePath) $ do+ describe "SpeechText toJSON" $ do+ context "when it is a TextToSpeech" $+ it "should have the desired structure" $+ let textToSpeech = TextToSpeech "the text"+ in checkSerialization (messagePath "text_to_speech.json") textToSpeech+ context "when it is a SSML" $+ it "should have the desired structure" $+ let ssml = SSML "the xml"+ in checkSerialization (messagePath "ssml.json") ssml+ describe "SimpleResponse toJSON" $ do+ context "when it has a TextToSpeech" $+ it "should have the desired structure" $+ let simpleResponse = SimpleResponse (TextToSpeech "the text") (Just "the maybe text")+ in checkSerialization (messagePath "simple_response_text.json") simpleResponse+ context "when it has a SSML" $+ it "should have the desired structure" $+ let simpleResponse = SimpleResponse (SSML "the xml") (Just "the maybe text")+ in checkSerialization (messagePath "simple_response_ssml.json") simpleResponse+ describe "CardButton toJSON" $+ it "should have the desired structure" $+ let cardButton = CardButton (Just "the text") (Just "the postback")+ in checkSerialization (messagePath "card_button.json") cardButton+ describe "BasicCardContent toJSON" $+ context "when it is an Image" $+ it "should have the desired structure" $+ let image = BasicCardImage (Image "the uri" (Just "the ally text"))+ in checkSerialization (messagePath "basic_card_image.json") image+ describe "OpenUriAction toJSON" $+ it "should have the desired structure" $+ let openUriAction = OpenUriAction "the uri"+ in checkSerialization (messagePath "open_uri_action.json") openUriAction+ describe "BasicCardButton toJSON" $+ it "should have the desired structure" $+ let openUriAction = OpenUriAction "the uri"+ basicCardButton = BasicCardButton "the title" openUriAction+ in checkSerialization (messagePath "basic_card_button.json") basicCardButton+ describe "Suggestion toJSON" $+ it "should have the desired structure" $+ let suggestion = Suggestion "the title"+ in checkSerialization (messagePath "suggestion.json") suggestion+ describe "SelectedItemInfo toJSON" $+ it "should have the desired structure" $+ checkSerialization (messagePath "selected_item_info.json") selectedItemInfo+ describe "Item toJSON" $+ it "should have the desired structure" $+ checkSerialization (messagePath "item.json") item+ describe "Message toJSON" $ do+ context "Text" $+ it "should have the desired structure" $+ let text = Text (Just ["the text"])+ in checkSerialization (messagePath "text.json") text+ context "Image" $+ it "should have the desired structure" $+ let image = Image "the uri" (Just "the ally text")+ in checkSerialization (messagePath "image.json") image+ context "QuickReplies" $+ it "should have the desired structure" $+ let quickReplies = QuickReplies (Just "the title") ["the reply"]+ in checkSerialization (messagePath "quick_replies.json") quickReplies+ context "Card" $+ it "should have the desired structure" $+ let cardButton = CardButton (Just "the text") (Just "the postback")+ card =+ Card (Just "the title") (Just "the subtitle") (Just "the uri") (Just [cardButton])+ in checkSerialization (messagePath "card_image.json") card+ context "SimpleResponses" $+ it "should have the desired structure" $+ let simpleResponses = SimpleResponses [SimpleResponse (TextToSpeech "the text") (Just "the display text")]+ in checkSerialization (messagePath "simple_responses.json") simpleResponses+ context "BasicCard" $ do+ context "when it has an image content" $+ it "should have the desired structure" $+ let image = Image "the uri" (Just "the ally text")+ openUriAction = OpenUriAction "the uri"+ basicCardButton = BasicCardButton "the title" openUriAction+ basicCard =+ BasicCard (Just "the title") (Just "the subtitle") (BasicCardImage image) (Just [basicCardButton])+ in checkSerialization (messagePath "basic_card_with_image.json") basicCard+ context "when it has a formattedText content" $+ it "should have the desired structure" $+ let openUriAction = OpenUriAction "the uri"+ basicCardButton = BasicCardButton "the title" openUriAction+ basicCard =+ BasicCard (Just "the title") (Just "the subtitle") (BasicCardFormattedText "the formatted text") (Just [basicCardButton])+ in checkSerialization (messagePath "basic_card_with_text.json") basicCard+ context "Suggestions" $+ it "should have the desired structure" $+ let suggestions = Suggestions [Suggestion "the suggestion"]+ in checkSerialization (messagePath "suggestions.json") suggestions+ context "LinkOutSuggestion" $+ it "should have the desired structure" $+ let linkOutSuggestion = LinkOutSuggestion "the name" "the app"+ in checkSerialization (messagePath "link_out_suggestion.json") linkOutSuggestion+ context "ListSelect" $+ it "should have the desired structure" $+ let listSelect = ListSelect (Just "the title") [item]+ in checkSerialization (messagePath "list_select.json") listSelect+ context "CarouselSelect" $+ it "should have the desired structure" $+ let carouselSelect = CarouselSelect [item]+ in checkSerialization (messagePath "carousel_select.json") carouselSelect+ where+ selectedItemInfo = SelectItemInfo "the key" (Just ["a synonym"])+ image = Image "the uri" (Just "the ally text")+ item = Item selectedItemInfo "the title" (Just "the description") image
+ test/Dialogflow/V2/Fulfillment/Payload/GoogleSpec.hs view
@@ -0,0 +1,102 @@+module Dialogflow.V2.Fulfillment.Payload.GoogleSpec where++import Test.Hspec++import TestUtil+import Dialogflow.V2.Fulfillment.Payload.Google+import Data.Aeson++import qualified Dialogflow.V2.Fulfillment.Message as M++basePath :: FilePath+basePath = "files/payload/google/"++googlePayloadPath :: FilePath -> FilePath+googlePayloadPath = (<>) basePath++spec :: Spec+spec = beforeAll (prepareDirs basePath) $ do+ describe "Image to/parseJSON instances" $+ it "Should have the desired structure" $+ checkSerialization (googlePayloadPath "image.json") image+ describe "BasicCardContent to/parseJSON instances" $ do+ context "when the content is an image" $+ it "should have the desired structure" $+ let basicCardImage = BasicCardImage image+ in checkSerialization (googlePayloadPath "basic_card_image.json") basicCardImage+ context "when the content is formatted text" $+ it "should have the desired structure" $+ let basicCardText = BasicCardFormattedText "the formatted text"+ in checkSerialization (googlePayloadPath "basic_card_formatted_text.json") basicCardText+ describe "ImageDisplayOption to/parseJSON instances" $ do+ context "when the value is DEFAULT" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "image_display_option_default.json") DEFAULT+ context "when the value is WHITE" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "image_display_option_white.json") WHITE+ context "when the value is WHITE" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "image_display_option_cropped.json") CROPPED+ describe "MediaType to/parseJSON instances" $ do+ context "When the value is MEDIA_TYPE_UNSPECIFIED" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "media_type_unspecified.json") MEDIA_TYPE_UNSPECIFIED+ context "When the value is AUDIO" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "media_type_audio.json") AUDIO+ describe "MediaObject to/parseJSON instances" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "media_object.json") mediaObject+ describe "UrlTypeHint to/parseJSON instances" $ do+ context "URL_TYPE_HINT_UNSPECIFIED" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "url_type_hint_unspecified.json") URL_TYPE_HINT_UNSPECIFIED+ context "AMP_CONTENT" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "url_type_hint_amp_content.json") AMP_CONTENT+ describe "VersionFilter to/parseJSON instances" $+ it "should have the desired structure" $+ let versionFilter = VersionFilter 1 2+ in checkSerialization (googlePayloadPath "version_filter.json") versionFilter+ describe "AndroidApp to/parseJSON instances" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "android_app.json") androidApp+ describe "OpenUrlAction to/parseJSON instances" $+ it "should have the desired structure" $+ checkSerialization (googlePayloadPath "open_url_action.json") openUrlAction+ describe "LinkOutSuggestion to/parseJSON instances" $+ it "should have the desired structure" $+ let linkOutSuggestion = LinkOutSuggestion "the destination name" "the url" openUrlAction+ in checkSerialization (googlePayloadPath "open_url_action.json") openUrlAction+ describe "Suggestion to/parseJSON instances" $+ it "should have the desired structure" $+ let suggestion = Suggestion "the suggestion"+ in checkSerialization (googlePayloadPath "suggestion.json") suggestion+ describe "Item to/parseJSON instances" $ do+ context "SimpleResponse" $+ it "should have the desired structure" $+ let simpleResponse =+ SimpleResponse (M.SimpleResponse (M.TextToSpeech "the tts") (Just "the display text"))+ in checkSerialization (googlePayloadPath "simple_response.json") simpleResponse+ context "BasicCard" $+ it "should have the desired structure" $+ let basicCard =+ BasicCard (Just "the title") (Just "the subtitle") (BasicCardImage image) [] DEFAULT+ in checkSerialization (googlePayloadPath "basic_card.json") basicCard+ context "MediaResponse" $+ it "should have the desired structure" $+ let mediaResponse = MediaResponse AUDIO [mediaObject]+ in checkSerialization (googlePayloadPath "media_response.json") mediaResponse+ where+ image :: Image+ image = Image "the url" "the ally text" (Just 300) (Just 700)++ androidApp :: AndroidApp+ androidApp = AndroidApp "the package name" [VersionFilter 1 2]++ openUrlAction :: OpenUrlAction+ openUrlAction = OpenUrlAction "the url" androidApp URL_TYPE_HINT_UNSPECIFIED++ mediaObject :: MediaObject+ mediaObject = MediaObject "the name" "the description" "the content url" image image
+ test/Dialogflow/V2/Fulfillment/Webhook/RequestSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Dialogflow.V2.Fulfillment.Webhook.RequestSpec where++import Data.Aeson (eitherDecode)+import Test.Hspec+import qualified Data.Map as M++import Dialogflow.V2.Fulfillment.Webhook.Request+import TestUtil++basePath :: FilePath+basePath = "files/request/"++requestPath :: FilePath -> FilePath+requestPath = (<>) basePath++spec :: Spec+spec = beforeAll (prepareDirs basePath) $ do+ describe "Context to/parseJSON" $+ it "should have the desired structure" $+ let ctx =+ Context "the context name" (Just 5) (Just $ M.fromList [("param1", "value1"),("param2","value2")])+ in checkSerialization (requestPath "context.json") ctx+ describe "Intent to/parseJSON" $+ it "should have the desired structure" $+ let intent = Intent "the intent name" "the display name"+ in checkSerialization (requestPath "intent.json") intent+ describe "QueryResult" $+ it "should have the desired structure" $+ checkSerialization (requestPath "query_result.json") queryResult+ describe "WebhookRequest to/parseJSON" $+ it "should have the desired structure" $+ let req = WebhookRequest "the response id" "the session" queryResult+ in checkSerialization (requestPath "webhook_request.json") req+ where+ queryResult =+ QueryResult "the original text"+ (M.fromList [("param1","value1")])+ True+ (Just "the fulfillment text")+ (Just [])+ (Just $ Intent "the intent name" "the display name")+ (Just 10.5)+ (Just $ M.fromList [])+ "esES"
+ test/Dialogflow/V2/Fulfillment/Webhook/ResponseSpec.hs view
@@ -0,0 +1,23 @@+module Dialogflow.V2.Fulfillment.Webhook.ResponseSpec where++import Test.Hspec++import qualified Data.Map as M++import Dialogflow.V2.Fulfillment.Webhook.Response+import TestUtil++basePath :: FilePath+basePath = "files/response/"++responsePath :: FilePath -> FilePath+responsePath = (<>) basePath++spec :: Spec+spec = beforeAll (prepareDirs basePath) $+ describe "EventInput to/parseJSON instances" $+ it "should have the desired structure" $+ let eventInput =+ EventInput "the name"+ (Just $ M.fromList [("param1","value1")]) "esES"+ in checkSerialization (responsePath "event_input.json") eventInput
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestUtil.hs view
@@ -0,0 +1,32 @@+module TestUtil where++import Control.Exception (bracket)+import Control.Monad (void)+import Data.Aeson (encodeFile, decode, ToJSON, FromJSON)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Bool (bool)+import System.Directory ( createDirectoryIfMissing+ , removeDirectoryRecursive+ , doesDirectoryExist )+import System.IO (withFile, IOMode(ReadMode))+import Test.Hspec (shouldBe)++import qualified Data.ByteString.Lazy as B++prepareDirs :: FilePath -> IO ()+prepareDirs path = removeRootOutputDir path >> createDirectoryIfMissing True path++removeRootOutputDir :: FilePath -> IO ()+removeRootOutputDir path = do+ exists <- doesDirectoryExist path+ bool (return ()) (removeDirectoryRecursive path) exists++checkSerialization :: (FromJSON a, ToJSON a, Show a, Eq a)+ => FilePath+ -> a+ -> IO ()+checkSerialization path x = do+ B.writeFile path $ encodePretty x+ withFile path ReadMode $ \h -> do+ contents <- B.hGetContents h+ Just x `shouldBe` decode contents