telegram-api 0.6.3.0 → 0.7.0.0
raw patch · 5 files changed
+70/−59 lines, 5 filesdep ~servantdep ~servant-client
Dependency ranges changed: servant, servant-client
Files
- CHANGELOG.md +4/−0
- README.md +5/−5
- src/Servant/Client/MultipartFormData.hs +37/−35
- telegram-api.cabal +5/−5
- test/MainSpec.hs +19/−14
CHANGELOG.md view
@@ -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`.
README.md view
@@ -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<token>" -- entire Token should be bot123456:ABC-DEF1234ghIkl-zyx57W2v1u123ew11- chatId = "<chat_id> or <@channelusername>"+ chatId = ChatId <chat_id> -- 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 } ```
src/Servant/Client/MultipartFormData.hs view
@@ -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)
telegram-api.cabal view
@@ -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
test/MainSpec.hs view
@@ -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