diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.7.0.0 + +* Upgraded to servant-0.11 + ## 0.6.3.0 * New fields *gif_duration* in `InlineQueryResultGif` and *mpeg4_duration* in `InlineQueryResultMpeg4Gif`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -41,7 +41,7 @@ print "done!" ``` -### Runing IO directly +### Running IO directly `getMe` example @@ -89,7 +89,7 @@ print $ message_id m print $ text m where token = Token "bot" -- entire Token should be bot123456:ABC-DEF1234ghIkl-zyx57W2v1u123ew11 - chatId = " or <@channelusername>" + chatId = ChatId -- use ChatId 10231 or ChatChannel "<@channelusername>" message = "text *bold* _italic_ [github](github.com/klappvisor/haskell-telegram-api)" ``` @@ -100,16 +100,16 @@ With data type constructor: ```haskell -let request = SendMessageRequest "chatId" "text" Nothing (Just True) Nothing Nothing Nothing +let request = SendMessageRequest (ChatId int64_chatId) "text" Nothing (Just True) Nothing Nothing Nothing ``` Using default instance: ```haskell -let request = sendMessageRequest "chatId" "text" -- only with required fields +let request = sendMessageRequest (ChatId int64_chatId) "text" -- only with required fields ``` ```haskell -let request = (sendMessageRequest "chatId" "text") { +let request = (sendMessageRequest ChatId int64_chatId) "text") { message_disable_notification = Just True -- with optional fields } ``` diff --git a/src/Servant/Client/MultipartFormData.hs b/src/Servant/Client/MultipartFormData.hs --- a/src/Servant/Client/MultipartFormData.hs +++ b/src/Servant/Client/MultipartFormData.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.MultipartFormData ( ToMultipartFormData (..) @@ -14,25 +15,27 @@ import Control.Exception import Control.Monad -import Control.Monad.Reader.Class -import Control.Monad.IO.Class import Control.Monad.Error.Class -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Data.ByteString.Lazy hiding (elem, filter, + map, null, pack, any) import Data.Proxy +import Data.Foldable (toList) import Data.String.Conversions -import Data.Typeable (Typeable) -import Network.HTTP.Client hiding (Proxy, path) -import qualified Network.HTTP.Client as Client +import Data.Typeable (Typeable) +import Network.HTTP.Client hiding (Proxy, path) +import qualified Network.HTTP.Client as Client import Network.HTTP.Client.MultipartFormData import Network.HTTP.Media import Network.HTTP.Types -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP import Servant.API -import Servant.Common.BaseUrl import Servant.Client -import Servant.Common.Req (Req, catchConnectionError, - reqAccept, reqToRequest) +import Servant.Common.Req (Req, UrlReq (..), ClientEnv (..), + catchConnectionError, + reqAccept, reqToRequest) -- | A type that can be converted to a multipart/form-data value. class ToMultipartFormData a where -- | Convert a Haskell value to a multipart/form-data-friendly intermediate type. @@ -52,20 +55,20 @@ formDataBody (toMultipartFormData reqData) requestWithoutBody in snd <$> performRequestCT' reqToRequest' (Proxy :: Proxy ct) H.methodPost req --- copied `performRequest` from servant-0.7.1, then modified so it takes a variant of `reqToRequest` +-- copied `performRequest` from servant-0.11, then modified so it takes a variant of `reqToRequest` -- as an argument. performRequest' :: (Req -> BaseUrl -> IO Request) - -> Method -> Req -> Manager -> BaseUrl + -> Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) -performRequest' reqToRequest' reqMethod req manager reqHost = do +performRequest' reqToRequest' reqMethod req = do + m <- asks manager + reqHost <- asks baseUrl partialRequest <- liftIO $ reqToRequest' req reqHost - let request = partialRequest { Client.method = reqMethod - , checkResponse = \ _request _response -> return () - } + let request = partialRequest { Client.method = reqMethod } - eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager + eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of Left err -> throwError . ConnectionError $ SomeException err @@ -81,21 +84,20 @@ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse status ct body + throwError $ FailureResponse (UrlReq reqHost req) status ct body return (status_code, body, ct, hdrs, response) --- copied `performRequestCT` from servant-0.7.1, then modified so it takes a variant of `reqToRequest` +-- copied `performRequestCT` from servant-0.11, then modified so it takes a variant of `reqToRequest` -- as an argument. -performRequestCT' :: MimeUnrender ct result => - (Req -> BaseUrl -> IO Request) -> - Proxy ct -> Method -> Req +performRequestCT' :: MimeUnrender ct result => + (Req -> BaseUrl -> IO Request) + -> Proxy ct -> Method -> Req -> ClientM ([HTTP.Header], result) performRequestCT' reqToRequest' ct reqMethod req = do - let acceptCT = contentType ct - ClientEnv manager reqHost <- ask + let acceptCTS = contentTypes ct (_status, respBody, respCT, hdrs, _response) <- - performRequest' reqToRequest' reqMethod (req { reqAccept = [acceptCT] }) manager reqHost - unless (matches respCT acceptCT) $ throwError $ UnsupportedContentType respCT respBody + performRequest' reqToRequest' reqMethod (req { reqAccept = toList acceptCTS }) + unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwError $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) diff --git a/telegram-api.cabal b/telegram-api.cabal --- a/telegram-api.cabal +++ b/telegram-api.cabal @@ -1,5 +1,5 @@ name: telegram-api -version: 0.6.3.0 +version: 0.7.0.0 synopsis: Telegram Bot API bindings description: High-level bindings to the Telegram Bot API homepage: http://github.com/klappvisor/haskell-telegram-api#readme @@ -46,8 +46,8 @@ , aeson >= 1.0 && < 1.3 , http-api-data , http-client >= 0.5 && < 0.6 - , servant >= 0.9 && <0.11 - , servant-client >= 0.9 && <0.11 + , servant >= 0.11 && <0.12 + , servant-client >= 0.11 && <0.12 , mtl >= 2.2 && < 2.3 , text , transformers @@ -77,8 +77,8 @@ , http-types , hspec , optparse-applicative - , servant >= 0.9 && <0.11 - , servant-client >= 0.9 && <0.11 + , servant >= 0.11 && <0.12 + , servant-client >= 0.11 && <0.12 , telegram-api , http-types , filepath diff --git a/test/MainSpec.hs b/test/MainSpec.hs --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -116,7 +116,7 @@ Left FailureResponse { responseStatus = Status { statusMessage = msg } } <- sendPhoto token photo manager msg `shouldBe` "Bad Request" it "should upload photo and resend it by id" $ do - let fileUpload = localFileUpload (testFile "christmas-cat.jpg") + let fileUpload = localFileUpload $ testFile "christmas-cat.jpg" let upload = (uploadPhotoRequest chatId fileUpload) { photo_caption = Just "uploaded photo" } @@ -142,20 +142,21 @@ sendAudio token audio manager msg `shouldBe` "Bad Request" it "should upload audio and resend it by id" $ do - let fileUpload = localFileUpload (testFile "concerto-for-2-trumpets-in-c-major.mp3") + let fileUpload = localFileUpload $ testFile "concerto-for-2-trumpets-in-c-major.mp3" audioTitle = "Concerto for 2 Trumpets in C major, RV. 537 (Rondeau arr.) All." audioPerformer = "Michel Rondeau" audio = (uploadAudioRequest chatId fileUpload) { _audio_performer = Just audioPerformer, _audio_title = Just audioTitle } - Right Response { + res <- uploadAudio token audio manager + let Right Response { result = Message { audio = Just Audio { audio_file_id = file_id, audio_title = Just title, audio_performer = Just performer } } - } <- uploadAudio token audio manager + } = res title `shouldBe` audioTitle performer `shouldBe` audioPerformer let audio = sendAudioRequest chatId file_id @@ -170,19 +171,21 @@ sendSticker token sticker manager sticker_file_id sticker `shouldBe` "CAADAgADGgADkWgMAAGXlYGBiM_d2wI" --"BQADAgADGgADkWgMAAGXlYGBiM_d2wI" it "should upload sticker" $ do - let fileUpload = localFileUpload (testFile "haskell-logo.webp") + let fileUpload = localFileUpload $ testFile "haskell-logo.webp" stickerReq = uploadStickerRequest chatId fileUpload - Right Response { result = Message { sticker = Just sticker } } <- - uploadSticker token stickerReq manager + res <- uploadSticker token stickerReq manager + success res + let Right Response { result = Message { sticker = Just sticker } } = res sticker_height sticker `shouldBe` 128 describe "/sendVoice" $ it "should upload voice" $ do -- audio source: https://commons.wikimedia.org/wiki/File:Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg - let fileUpload = localFileUpload (testFile "Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg") + let fileUpload = localFileUpload $ testFile "Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg" voiceReq = (uploadVoiceRequest chatId fileUpload) { _voice_duration = Just 10 } - Right Response { result = Message { voice = Just voice } } <- - uploadVoice token voiceReq manager + res <- uploadVoice token voiceReq manager + success res + let Right Response { result = Message { voice = Just voice } } = res voice_duration voice `shouldBe` 10 describe "/sendVideoNote" $ it "should upload video note" $ do @@ -197,15 +200,17 @@ describe "/sendVideo" $ it "should upload video" $ do -- video source: http://techslides.com/sample-webm-ogg-and-mp4-video-files-for-html5 - let fileUpload = localFileUpload (testFile "lego-video.mp4") + let fileUpload = localFileUpload $ testFile "lego-video.mp4" videoReq = uploadVideoRequest chatId fileUpload - Right Response { result = Message { video = Just video } } <- - uploadVideo token videoReq manager + res <- uploadVideo token videoReq manager + success res + let Right Response { result = Message { video = Just video } } = res + video_width video `shouldBe` 560 describe "/sendDocument" $ it "should upload document" $ do - let fileUpload = localFileUpload (testFile "wikipedia-telegram.txt") + let fileUpload = localFileUpload $ testFile "wikipedia-telegram.txt" documentReq = uploadDocumentRequest chatId fileUpload Right Response { result = Message { document = Just document } } <- uploadDocument token documentReq manager