diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for dialogflow-fulfillment + +## 0.1.0.0 -- 2019-09-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +[![Build Status](https://travis-ci.org/mauriciofierrom/dialogflow-fulfillment.svg?branch=master)](https://travis-ci.org/mauriciofierrom/dialogflow-fulfillment) + +# dialogflow-fulfillment + +A basic library to create responses for Google's Dialogflow fulfilment webhooks. 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/dialogflow-fulfillment.cabal b/dialogflow-fulfillment.cabal new file mode 100644 --- /dev/null +++ b/dialogflow-fulfillment.cabal @@ -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 + . + . + Check how fulfillment works in the Dialogflow + . + +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 diff --git a/src/Dialogflow/Util.hs b/src/Dialogflow/Util.hs new file mode 100644 --- /dev/null +++ b/src/Dialogflow/Util.hs @@ -0,0 +1,35 @@ +{-| +Module : Dialogflow.Util +Description : Utilities +Copyright : (c) Mauricio Fierro, 2019 +License : BSD3-Clause +Maintainer : Mauricio Fierro + +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) diff --git a/src/Dialogflow/V2/Fulfillment/Message.hs b/src/Dialogflow/V2/Fulfillment/Message.hs new file mode 100644 --- /dev/null +++ b/src/Dialogflow/V2/Fulfillment/Message.hs @@ -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 + +This module contains types for Dialogflow messages to be used in +a fulfillment webhook response. See the Dialogflow . +-} + +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 ] diff --git a/src/Dialogflow/V2/Fulfillment/Payload/Google.hs b/src/Dialogflow/V2/Fulfillment/Payload/Google.hs new file mode 100644 --- /dev/null +++ b/src/Dialogflow/V2/Fulfillment/Payload/Google.hs @@ -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 + +This module contains types for the Google Actions payload to be included +in the webhook reponse. See the Dialogflow . +-} + +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 ] diff --git a/src/Dialogflow/V2/Fulfillment/Webhook/Request.hs b/src/Dialogflow/V2/Fulfillment/Webhook/Request.hs new file mode 100644 --- /dev/null +++ b/src/Dialogflow/V2/Fulfillment/Webhook/Request.hs @@ -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 + +This module contains types for Dialogflow webhook requests. See the Dialogflow . +-} + +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 diff --git a/src/Dialogflow/V2/Fulfillment/Webhook/Response.hs b/src/Dialogflow/V2/Fulfillment/Webhook/Response.hs new file mode 100644 --- /dev/null +++ b/src/Dialogflow/V2/Fulfillment/Webhook/Response.hs @@ -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 + +This module contains types for Dialogflow webhook response. See the Dialogflow . +-} + +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 ] diff --git a/test/Dialogflow/V2/Fulfillment/MessageSpec.hs b/test/Dialogflow/V2/Fulfillment/MessageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dialogflow/V2/Fulfillment/MessageSpec.hs @@ -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 diff --git a/test/Dialogflow/V2/Fulfillment/Payload/GoogleSpec.hs b/test/Dialogflow/V2/Fulfillment/Payload/GoogleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dialogflow/V2/Fulfillment/Payload/GoogleSpec.hs @@ -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 diff --git a/test/Dialogflow/V2/Fulfillment/Webhook/RequestSpec.hs b/test/Dialogflow/V2/Fulfillment/Webhook/RequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dialogflow/V2/Fulfillment/Webhook/RequestSpec.hs @@ -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" diff --git a/test/Dialogflow/V2/Fulfillment/Webhook/ResponseSpec.hs b/test/Dialogflow/V2/Fulfillment/Webhook/ResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Dialogflow/V2/Fulfillment/Webhook/ResponseSpec.hs @@ -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 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 #-} diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/TestUtil.hs @@ -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