diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -57,4 +57,4 @@ fi after_script: - - "[ -n \"$USE_COVERALLS\" ] && hpc-coveralls spec_main || true" + - "[ -n \"$USE_COVERALLS\" ] && hpc-coveralls --exclude-dir=tests spec_main || true" diff --git a/Web/Twitter/Conduit.hs b/Web/Twitter/Conduit.hs --- a/Web/Twitter/Conduit.hs +++ b/Web/Twitter/Conduit.hs @@ -25,8 +25,19 @@ , module Web.Twitter.Conduit.Request , module Web.Twitter.Conduit.Parameters , module Web.Twitter.Types.Lens + + , MediaData (..) + , UploadedMedia + , mediaId + , mediaSize + , mediaImage + , ImageSizeType + , imageWidth + , imageHeight + , imageType ) where +import Web.Twitter.Conduit.Types import Web.Twitter.Conduit.Base import Web.Twitter.Conduit.Api import Web.Twitter.Conduit.Status diff --git a/Web/Twitter/Conduit/Api.hs b/Web/Twitter/Conduit/Api.hs --- a/Web/Twitter/Conduit/Api.hs +++ b/Web/Twitter/Conduit/Api.hs @@ -125,15 +125,20 @@ -- geoSearch -- geoSimilarPlaces -- geoPlace + + -- * media + , MediaUpload + , mediaUpload ) where import Web.Twitter.Types +import Web.Twitter.Conduit.Types import Web.Twitter.Conduit.Parameters import Web.Twitter.Conduit.Parameters.TH import Web.Twitter.Conduit.Base import Web.Twitter.Conduit.Request -import Web.Twitter.Conduit.Cursor +import Network.HTTP.Client.MultipartFormData import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Default @@ -555,3 +560,33 @@ , "skip_status" ] +data MediaUpload +-- | Upload media and returns the media data. +-- +-- You can update your status with multiple media by calling 'mediaUpload' and 'update' successively. +-- +-- First, you should upload media with 'mediaUpload': +-- +-- @ +-- res1 <- 'call' '$' 'mediaUpload' ('MediaFromFile' \"\/path\/to\/upload\/file1.png\") +-- res2 <- 'call' '$' 'mediaUpload' ('MediaRequestBody' \"file2.png\" \"[.. file body ..]\") +-- @ +-- +-- and then collect the resulting media IDs and update your status by calling 'update': +-- +-- @ +-- 'call' '$' 'update' \"Hello World\" '&' 'mediaIds' '?~' ['mediaId' res1, 'mediaId' res2] +-- @ +-- +-- See: +-- +-- >>> mediaUpload (MediaFromFile "/home/test/test.png") +-- APIRequestPostMultipart "https://upload.twitter.com/1.1/media/upload.json" [] +mediaUpload :: MediaData + -> APIRequest MediaUpload UploadedMedia +mediaUpload mediaData = + APIRequestPostMultipart uri [] [mediaBody mediaData] + where + uri = "https://upload.twitter.com/1.1/media/upload.json" + mediaBody (MediaFromFile fp) = partFileSource "media" fp + mediaBody (MediaRequestBody filename filebody) = partFileRequestBody "media" filename filebody diff --git a/Web/Twitter/Conduit/Base.hs b/Web/Twitter/Conduit/Base.hs --- a/Web/Twitter/Conduit/Base.hs +++ b/Web/Twitter/Conduit/Base.hs @@ -4,12 +4,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RecordWildCards #-} module Web.Twitter.Conduit.Base ( api , apiRequest , call , call' + , checkResponse , sourceWithMaxId , sourceWithCursor , TwitterBaseM @@ -22,13 +24,12 @@ import Prelude as P import Web.Twitter.Conduit.Monad -import Web.Twitter.Conduit.Error +import Web.Twitter.Conduit.Types import Web.Twitter.Conduit.Parameters import Web.Twitter.Conduit.Request -import Web.Twitter.Conduit.Cursor import Web.Twitter.Types.Lens -import Network.HTTP.Conduit +import qualified Network.HTTP.Conduit as HTTP import Network.HTTP.Client.MultipartFormData import qualified Network.HTTP.Types as HT import qualified Data.Conduit as C @@ -40,7 +41,6 @@ import qualified Data.Text.Encoding as T import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 -import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (MonadResource, MonadThrow, monadThrow) import Text.Shakespeare.Text @@ -52,41 +52,87 @@ , MonadLogger m ) -makeRequest :: MonadIO m +makeRequest :: MonadThrow m => HT.Method -- ^ HTTP request method (GET or POST) -> String -- ^ API Resource URL -> HT.SimpleQuery -- ^ Query - -> TW m Request + -> TW m HTTP.Request makeRequest m url query = do p <- getProxy - req <- liftIO $ parseUrl url - return $ req { method = m - , queryString = HT.renderSimpleQuery False query - , proxy = p } + req <- HTTP.parseUrl url + return $ req { HTTP.method = m + , HTTP.queryString = HT.renderSimpleQuery False query + , HTTP.proxy = p + , HTTP.checkStatus = \_ _ _ -> Nothing + } api :: TwitterBaseM m => HT.Method -- ^ HTTP request method (GET or POST) -> String -- ^ API Resource URL -> HT.SimpleQuery -- ^ Query - -> TW m (C.ResumableSource (TW m) ByteString) + -> TW m (Response (C.ResumableSource (TW m) ByteString)) api m url query = apiRequest =<< makeRequest m url query apiRequest :: TwitterBaseM m - => Request - -> TW m (C.ResumableSource (TW m) ByteString) + => HTTP.Request + -> TW m (Response (C.ResumableSource (TW m) ByteString)) apiRequest req = do signedReq <- signOAuthTW req $(logDebug) [st|Signed Request: #{show signedReq}|] mgr <- getManager - res <- http signedReq mgr - $(logDebug) [st|Response Status: #{show $ responseStatus res}|] - $(logDebug) [st|Response Header: #{show $ responseHeaders res}|] - return $ responseBody res + res <- HTTP.http signedReq mgr + $(logDebug) [st|Response Status: #{show $ HTTP.responseStatus res}|] + $(logDebug) [st|Response Header: #{show $ HTTP.responseHeaders res}|] + return + Response { responseStatus = HTTP.responseStatus res + , responseHeaders = HTTP.responseHeaders res + , responseBody = HTTP.responseBody res + } endpoint :: String endpoint = "https://api.twitter.com/1.1/" +getValue :: (MonadLogger m, MonadThrow m) + => Response (C.ResumableSource (TW m) ByteString) + -> TW m (Response Value) +getValue res = do + value <- responseBody res C.$$+- sinkJSON + return $ res { responseBody = value } + +checkResponse :: Response Value + -> Either TwitterError Value +checkResponse Response{..} = + case responseBody ^? key "errors" of + Just errs -> + case fromJSON errs of + Success errList -> Left $ TwitterErrorResponse responseStatus responseHeaders errList + Error msg -> Left $ FromJSONError msg + Nothing -> + if sci < 200 || sci > 400 + then Left $ TwitterStatusError responseStatus responseHeaders responseBody + else Right responseBody + where + sci = HT.statusCode responseStatus + +getValueOrThrow :: (MonadThrow m, MonadLogger m, FromJSON a) + => Response (C.ResumableSource (TW m) ByteString) + -> TW m a +getValueOrThrow res = do + val <- getValueOrThrow' res + case fromJSON val of + Success r -> return r + Error err -> monadThrow $ FromJSONError err + +getValueOrThrow' :: (MonadLogger m, MonadThrow m) + => Response (C.ResumableSource (TW m) ByteString) + -> TW m Value +getValueOrThrow' res = do + res' <- getValue res + case checkResponse res' of + Left err -> monadThrow err + Right v -> return v + apiValue :: (TwitterBaseM m, FromJSON a) => HT.Method -- ^ HTTP request method (GET or POST) -> String -- ^ API Resource URL @@ -94,7 +140,7 @@ -> TW m a apiValue m url query = do src <- api m url query - src C.$$+- sinkFromJSON + getValueOrThrow src call :: (TwitterBaseM m, FromJSON responseType) => APIRequest apiName responseType @@ -109,7 +155,7 @@ call' (APIRequestPostMultipart u param prt) = do req <- formDataBody body =<< makeRequest "POST" u [] src <- apiRequest req - src C.$$+- sinkFromJSON + getValueOrThrow src where body = prt ++ partParam partParam = P.map (uncurry partBS . over _1 T.decodeUtf8) param @@ -197,7 +243,7 @@ sinkFromJSON = do v <- sinkJSON case fromJSON v of - Error err -> lift $ monadThrow $ TwitterError err + Error err -> monadThrow $ FromJSONError err Success r -> return r showBS :: Show a => a -> ByteString diff --git a/Web/Twitter/Conduit/Cursor.hs b/Web/Twitter/Conduit/Cursor.hs deleted file mode 100644 --- a/Web/Twitter/Conduit/Cursor.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -module Web.Twitter.Conduit.Cursor - ( CursorKey (..) - , IdsCursorKey - , UsersCursorKey - , WithCursor (..) - ) where - -import Web.Twitter.Types (checkError) -import qualified Data.Text as T -import Data.Aeson -import Data.Monoid -import Control.Applicative - --- $setup --- >>> type UserId = Integer - -class CursorKey a where - cursorKey :: a -> T.Text - --- | Phantom type to specify the key which point out the content in the response. -data IdsCursorKey -instance CursorKey IdsCursorKey where - cursorKey = const "ids" - --- | Phantom type to specify the key which point out the content in the response. -data UsersCursorKey -instance CursorKey UsersCursorKey where - cursorKey = const "users" - -#if __GLASGOW_HASKELL__ >= 706 --- | A wrapper for API responses which have "next_cursor" field. --- --- The first type parameter of 'WithCursor' specifies the field name of contents. --- --- >>> let Just res = decode "{\"previous_cursor\": 0, \"next_cursor\": 1234567890, \"ids\": [1111111111]}" :: Maybe (WithCursor IdsCursorKey UserId) --- >>> nextCursor res --- 1234567890 --- >>> contents res --- [1111111111] --- --- >>> let Just res = decode "{\"previous_cursor\": 0, \"next_cursor\": 0, \"users\": [1000]}" :: Maybe (WithCursor UsersCursorKey UserId) --- >>> nextCursor res --- 0 --- >>> contents res --- [1000] -#endif -data WithCursor cursorKey wrapped = WithCursor - { previousCursor :: Integer - , nextCursor :: Integer - , contents :: [wrapped] - } deriving Show - -instance (FromJSON wrapped, CursorKey c) => - FromJSON (WithCursor c wrapped) where - parseJSON (Object o) = checkError o >> - WithCursor <$> o .: "previous_cursor" - <*> o .: "next_cursor" - <*> o .: cursorKey (undefined :: c) - parseJSON _ = mempty diff --git a/Web/Twitter/Conduit/Error.hs b/Web/Twitter/Conduit/Error.hs deleted file mode 100644 --- a/Web/Twitter/Conduit/Error.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Web.Twitter.Conduit.Error - ( TwitterError (..) - ) where - -import Control.Exception -import Data.Data - -data TwitterError - = TwitterError String - deriving (Show, Data, Typeable) - -instance Exception TwitterError - diff --git a/Web/Twitter/Conduit/Parameters.hs b/Web/Twitter/Conduit/Parameters.hs --- a/Web/Twitter/Conduit/Parameters.hs +++ b/Web/Twitter/Conduit/Parameters.hs @@ -24,6 +24,7 @@ , HasSkipStatusParam (..) , HasFollowParam (..) , HasMapParam (..) + , HasMediaIdsParam (..) , UserParam(..) , UserListParam(..) @@ -73,6 +74,7 @@ defineHasParamClass "skip_status" ''Bool 'booleanQuery defineHasParamClass "follow" ''Bool 'booleanQuery defineHasParamClass "map" ''Bool 'booleanQuery +defineHasParamClass' "media_ids" [t|[Integer]|] 'integerArrayQuery -- | converts 'UserParam' to 'HT.SimpleQuery'. -- diff --git a/Web/Twitter/Conduit/Parameters/Internal.hs b/Web/Twitter/Conduit/Parameters/Internal.hs --- a/Web/Twitter/Conduit/Parameters/Internal.hs +++ b/Web/Twitter/Conduit/Parameters/Internal.hs @@ -5,12 +5,14 @@ ( Parameters(..) , readShow , booleanQuery + , integerArrayQuery , wrappedParam ) where import qualified Network.HTTP.Types as HT import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import Data.Maybe import Control.Lens class Parameters a where @@ -52,6 +54,35 @@ sb "1" = Just True sb "t" = Just True sb _ = Just False + +-- | This 'Prism' convert from a 'ByteString' to the array of 'Integer' value. +-- +-- This is not a valid Prism, for example: +-- +-- @ +-- "1, 2" ^? integerArrayQuery == Just [1,2] +-- integerArrayQuery # [1,2] != "1, 2" +-- @ +-- +-- >>> integerArrayQuery # [1] +-- "1" +-- >>> integerArrayQuery # [1,2234,3] +-- "1,2234,3" +-- >>> "1,2234,3" ^? integerArrayQuery +-- Just [1,2234,3] +-- >>> "" ^? integerArrayQuery +-- Just [] +-- >>> "hoge,2" ^? integerArrayQuery +-- Nothing +integerArrayQuery :: Prism' S.ByteString [Integer] +integerArrayQuery = prism' bs_arr arr_bs + where + bs_arr xs = S8.intercalate "," $ xs ^.. traversed . re readShow + arr_bs str = chkValid $ map (^? readShow) $ S8.split ',' str + chkValid arr = + if all isJust arr + then Just (catMaybes arr) + else Nothing wrappedParam :: Parameters p => S.ByteString -> Prism' S.ByteString a -> Lens' p (Maybe a) wrappedParam key aSBS = lens getter setter diff --git a/Web/Twitter/Conduit/Parameters/TH.hs b/Web/Twitter/Conduit/Parameters/TH.hs --- a/Web/Twitter/Conduit/Parameters/TH.hs +++ b/Web/Twitter/Conduit/Parameters/TH.hs @@ -29,19 +29,23 @@ -> Name -- ^ parameter type -> Name -- ^ a Prism -> Q [Dec] -defineHasParamClass paramName typeN prismN = - defineHasParamClass' cNameS fNameS paramName typeN prismN +defineHasParamClass paramName typeN = + defineHasParamClass' paramName (conT typeN) + +defineHasParamClass' :: String -> TypeQ -> Name -> Q [Dec] +defineHasParamClass' paramName typeQ = + defineHasParamClass'' cNameS fNameS paramName typeQ where cNameS = paramNameToClassName paramName fNameS = snakeToLowerCamel paramName -defineHasParamClass' :: String -> String -> String -> Name -> Name -> Q [Dec] -defineHasParamClass' cNameS fNameS paramName typeN prismN = do +defineHasParamClass'' :: String -> String -> String -> TypeQ -> Name -> Q [Dec] +defineHasParamClass'' cNameS fNameS paramName typeQ prismN = do a <- newName "a" cName <- newName cNameS fName <- newName fNameS let cCxt = cxt [classP ''Parameters [varT a]] - tySig = sigD fName (appT (appT (conT ''Lens') (varT a)) (appT (conT ''Maybe) (conT typeN))) + tySig = sigD fName (appT (appT (conT ''Lens') (varT a)) (appT (conT ''Maybe) typeQ)) valDef = valD (varP fName) (normalB (appE (appE (varE 'wrappedParam) (litE (stringL paramName))) (varE prismN))) [] dec <- classD cCxt cName [PlainTV a] [] [tySig, valDef] return [dec] diff --git a/Web/Twitter/Conduit/Status.hs b/Web/Twitter/Conduit/Status.hs --- a/Web/Twitter/Conduit/Status.hs +++ b/Web/Twitter/Conduit/Status.hs @@ -43,6 +43,7 @@ import Prelude hiding ( lookup ) import Web.Twitter.Conduit.Base import Web.Twitter.Conduit.Request +import Web.Twitter.Conduit.Types import Web.Twitter.Conduit.Parameters import Web.Twitter.Conduit.Parameters.TH import Web.Twitter.Types @@ -51,7 +52,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Client.MultipartFormData -import Network.HTTP.Conduit import Data.Default -- $setup @@ -242,6 +242,7 @@ -- , "place_id" , "display_coordinates" , "trim_user" + , "media_ids" ] data StatusesRetweetId @@ -261,9 +262,6 @@ deriveHasParamInstances ''StatusesRetweetId [ "trim_user" ] - -data MediaData = MediaFromFile FilePath - | MediaRequestBody FilePath RequestBody data StatusesUpdateWithMedia -- | Returns post data which updates the authenticating user's current status and attaches media for upload. diff --git a/Web/Twitter/Conduit/Stream.hs b/Web/Twitter/Conduit/Stream.hs --- a/Web/Twitter/Conduit/Stream.hs +++ b/Web/Twitter/Conduit/Stream.hs @@ -20,6 +20,7 @@ , stream ) where +import Web.Twitter.Conduit.Types import Web.Twitter.Conduit.Base import Web.Twitter.Conduit.Monad import Web.Twitter.Types @@ -52,10 +53,10 @@ -> TW m (C.ResumableSource (TW m) value) stream' (APIRequestGet u pa) = do rsrc <- api "GET" u pa - rsrc $=+ CL.sequence sinkFromJSON + responseBody rsrc $=+ CL.sequence sinkFromJSON stream' (APIRequestPost u pa) = do rsrc <- api "POST" u pa - rsrc $=+ CL.sequence sinkFromJSON + responseBody rsrc $=+ CL.sequence sinkFromJSON stream' APIRequestPostMultipart {} = error "APIRequestPostMultipart is not supported by stream function." diff --git a/Web/Twitter/Conduit/Types.hs b/Web/Twitter/Conduit/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Conduit/Types.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module Web.Twitter.Conduit.Types + ( Response (..) + , TwitterError (..) + , TwitterErrorMessage (..) + , CursorKey (..) + , IdsCursorKey + , UsersCursorKey + , WithCursor (..) + , MediaData (..) + , UploadedMedia (..) + , ImageSizeType (..) + ) where + + +import Control.Applicative +import Control.Exception +import Data.Aeson +import Data.Data +import Data.Foldable (Foldable) +import Data.Monoid +import qualified Data.Text as T +import Data.Traversable (Traversable) +import Network.HTTP.Client (RequestBody) +import Network.HTTP.Types (Status, ResponseHeaders) +import Web.Twitter.Types (checkError) + +-- $setup +-- >>> type UserId = Integer + + +class CursorKey a where + cursorKey :: a -> T.Text + +-- | Phantom type to specify the key which point out the content in the response. +data IdsCursorKey +instance CursorKey IdsCursorKey where + cursorKey = const "ids" + +-- | Phantom type to specify the key which point out the content in the response. +data UsersCursorKey +instance CursorKey UsersCursorKey where + cursorKey = const "users" + +#if __GLASGOW_HASKELL__ >= 706 +-- | A wrapper for API responses which have "next_cursor" field. +-- +-- The first type parameter of 'WithCursor' specifies the field name of contents. +-- +-- >>> let Just res = decode "{\"previous_cursor\": 0, \"next_cursor\": 1234567890, \"ids\": [1111111111]}" :: Maybe (WithCursor IdsCursorKey UserId) +-- >>> nextCursor res +-- 1234567890 +-- >>> contents res +-- [1111111111] +-- +-- >>> let Just res = decode "{\"previous_cursor\": 0, \"next_cursor\": 0, \"users\": [1000]}" :: Maybe (WithCursor UsersCursorKey UserId) +-- >>> nextCursor res +-- 0 +-- >>> contents res +-- [1000] +#endif +data WithCursor cursorKey wrapped = WithCursor + { previousCursor :: Integer + , nextCursor :: Integer + , contents :: [wrapped] + } deriving Show + +instance (FromJSON wrapped, CursorKey c) => + FromJSON (WithCursor c wrapped) where + parseJSON (Object o) = checkError o >> + WithCursor <$> o .: "previous_cursor" + <*> o .: "next_cursor" + <*> o .: cursorKey (undefined :: c) + parseJSON _ = mempty + +data MediaData = MediaFromFile FilePath + | MediaRequestBody FilePath RequestBody + +data ImageSizeType = ImageSizeType + { imageWidth :: Int + , imageHeight :: Int + , imageType :: T.Text + } deriving Show +instance FromJSON ImageSizeType where + parseJSON (Object o) = + ImageSizeType <$> o .: "w" + <*> o .: "h" + <*> o .: "image_type" + parseJSON v = fail $ "unknown value: " ++ show v + +data UploadedMedia = UploadedMedia + { mediaId :: Integer + , mediaSize :: Integer + , mediaImage :: ImageSizeType + } deriving Show +instance FromJSON UploadedMedia where + parseJSON (Object o) = + UploadedMedia <$> o .: "media_id" + <*> o .: "size" + <*> o .: "image" + parseJSON v = fail $ "unknown value: " ++ show v + +data Response responseType = Response + { responseStatus :: Status + , responseHeaders :: ResponseHeaders + , responseBody :: responseType + } deriving (Show, Eq, Typeable, Functor, Foldable, Traversable) + +data TwitterError + = FromJSONError String + | TwitterErrorResponse Status ResponseHeaders [TwitterErrorMessage] + | TwitterStatusError Status ResponseHeaders Value + deriving (Show, Typeable, Eq) + +instance Exception TwitterError + +-- | Twitter Error Messages +-- +-- see detail: +data TwitterErrorMessage = TwitterErrorMessage + { twitterErrorCode :: Int + , twitterErrorMessage :: T.Text + } deriving (Show, Data, Typeable) + +instance Eq TwitterErrorMessage where + TwitterErrorMessage { twitterErrorCode = a } == TwitterErrorMessage { twitterErrorCode = b } + = a == b + +instance Ord TwitterErrorMessage where + compare TwitterErrorMessage { twitterErrorCode = a } TwitterErrorMessage { twitterErrorCode = b } + = a `compare` b + +instance Enum TwitterErrorMessage where + fromEnum = twitterErrorCode + toEnum a = TwitterErrorMessage a T.empty + +instance FromJSON TwitterErrorMessage where + parseJSON (Object o) = + TwitterErrorMessage + <$> o .: "code" + <*> o .: "message" + parseJSON v = fail $ "unexpected: " ++ show v diff --git a/Web/Twitter/Conduit/Types/Lens.hs b/Web/Twitter/Conduit/Types/Lens.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Conduit/Types/Lens.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Web.Twitter.Conduit.Types.Lens + ( TT.Response + , responseStatus + , responseBody + , responseHeaders + , TT.WithCursor + , previousCursor + , nextCursor + , contents + , TT.ImageSizeType + , imageWidth + , imageHeight + , imageType + , TT.UploadedMedia + , mediaId + , mediaSize + , mediaImage + , TT.TwitterErrorMessage + , twitterErrorMessage + , twitterErrorCode + ) where + +import qualified Web.Twitter.Conduit.Types as TT +import Web.Twitter.Conduit.Types.TH + +makeLenses ''TT.WithCursor +makeLenses ''TT.ImageSizeType +makeLenses ''TT.UploadedMedia +makeLenses ''TT.Response +makeLenses ''TT.TwitterErrorMessage diff --git a/Web/Twitter/Conduit/Types/TH.hs b/Web/Twitter/Conduit/Types/TH.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Conduit/Types/TH.hs @@ -0,0 +1,9 @@ +module Web.Twitter.Conduit.Types.TH + ( makeLenses + ) where + +import Control.Lens hiding (makeLenses) +import Language.Haskell.TH + +makeLenses :: Name -> Q [Dec] +makeLenses = makeLensesWith (defaultRules & lensField .~ Just) diff --git a/sample/oauth_pin.hs b/sample/oauth_pin.hs --- a/sample/oauth_pin.hs +++ b/sample/oauth_pin.hs @@ -16,6 +16,7 @@ import Data.Maybe import Data.Monoid import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource import Control.Monad.IO.Class import System.Environment import System.IO (hFlush, stdout) @@ -31,7 +32,7 @@ , oauthCallback = Just "oob" } -authorize :: (MonadBaseControl IO m, C.MonadResource m) +authorize :: (MonadBaseControl IO m, MonadResource m) => OAuth -- ^ OAuth Consumer key and secret -> Manager -> m Credential diff --git a/sample/postWithMultipleMedia.hs b/sample/postWithMultipleMedia.hs new file mode 100644 --- /dev/null +++ b/sample/postWithMultipleMedia.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Data.Text as T +import Web.Twitter.Conduit +import System.Environment +import System.Exit (exitFailure) +import System.IO +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad +import Common + +main :: IO () +main = runTwitterFromEnv' $ do + (status:filepathList) <- liftIO getArgs + when (length filepathList > 4) $ liftIO $ do + hPutStrLn stderr $ "You can upload upto 4 images in a single tweet, but we got " ++ show (length filepathList) ++ " images. abort." + exitFailure + uploadedMediaList <- forM filepathList $ \filepath -> do + liftIO $ putStrLn $ "Upload media: " ++ filepath + ret <- call $ mediaUpload (MediaFromFile filepath) + liftIO $ putStrLn $ "Upload completed: media_id: " ++ ret ^. mediaId . to show ++ ", filepath: " ++ filepath + return ret + liftIO $ putStrLn $ "Post message: " ++ status + res <- call $ update (T.pack status) & mediaIds ?~ (uploadedMediaList ^.. traversed . mediaId) + liftIO $ print res diff --git a/sample/simple.hs b/sample/simple.hs --- a/sample/simple.hs +++ b/sample/simple.hs @@ -26,7 +26,7 @@ , oauthConsumerSecret = error "You MUST specify oauthConsumerSecret parameter." } -authorize :: (MonadBaseControl IO m, C.MonadResource m) +authorize :: (MonadBaseControl IO m, MonadResource m) => OAuth -- ^ OAuth Consumer key and secret -> (String -> m String) -- ^ PIN prompt -> Manager diff --git a/tests/ApiSpec.hs b/tests/ApiSpec.hs --- a/tests/ApiSpec.hs +++ b/tests/ApiSpec.hs @@ -7,7 +7,7 @@ import qualified Data.Conduit.List as CL import Web.Twitter.Conduit (call, sourceWithCursor) import Web.Twitter.Conduit.Api -import Web.Twitter.Conduit.Cursor (contents) +import Web.Twitter.Conduit.Types.Lens import qualified Web.Twitter.Conduit.Parameters as Param import Web.Twitter.Types.Lens import Control.Lens @@ -35,7 +35,7 @@ describe "friendsIds" $ do it "returns a cursored collection of users IDs" $ do res <- run . call $ friendsIds (Param.ScreenNameParam "thimura") - length (contents res) `shouldSatisfy` (> 0) + res ^. contents . to length `shouldSatisfy` (> 0) it "iterate with sourceWithCursor" $ do friends <- run $ do @@ -46,7 +46,7 @@ describe "listsMembers" $ do it "returns a cursored collection of the member of specified list" $ do res <- run . call $ listsMembers (Param.ListNameParam "thimura/haskell") - length (contents res) `shouldSatisfy` (>= 0) + res ^. contents . to length `shouldSatisfy` (>= 0) it "should raise error when specified list does not exists" $ do let action = run . call $ listsMembers (Param.ListNameParam "thimura/haskell_ne") diff --git a/twitter-conduit.cabal b/twitter-conduit.cabal --- a/twitter-conduit.cabal +++ b/twitter-conduit.cabal @@ -1,5 +1,5 @@ name: twitter-conduit -version: 0.0.4 +version: 0.0.5 license: BSD3 license-file: LICENSE author: HATTORI Hiroki, Hideyuki Tanaka, Takahiro HIMURA @@ -71,10 +71,11 @@ exposed-modules: Web.Twitter.Conduit + Web.Twitter.Conduit.Types + Web.Twitter.Conduit.Types.Lens + Web.Twitter.Conduit.Types.TH Web.Twitter.Conduit.Base - Web.Twitter.Conduit.Cursor Web.Twitter.Conduit.Api - Web.Twitter.Conduit.Error Web.Twitter.Conduit.Monad Web.Twitter.Conduit.Stream Web.Twitter.Conduit.Status @@ -196,6 +197,7 @@ , data-default , resourcet , conduit + , conduit-extra , http-conduit , monad-logger , authenticate-oauth