diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Sigbjorn Finne, 2008. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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 b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,51 @@ += hs-twitter - Programming Twitter from Haskell = + +'hs-twitter' is a Haskell package providing a binding to +the Twitter API - + + http://twitter.com/ + http://apiwiki.twitter.com/REST+API+Documentation + +The binding is functionally complete (Christmas 2008), letting you write +applications in Haskell that accesses Twitter streams and updates your +own. + +For more info on use, please visit: http://haskell.forkIO.com/twitter + += Getting started = + +For some code samples showing you how to get started using this +API binding, have a look at Web/Twitter.hs at the top. + += Building and installing = + +This package is provided in Cabal form, so only thing you need to +do to get going is: + + foo% runghc Setup configure --user # that option being optional + foo% runghc Setup build + foo% runghc Setup install + +(or, if you are versed in its ways, "cabal update ; cabal install twitter") + +The package depends on a bunch of other packages though, so you +need to have them built&installed, as well. They are: + + * HTTP: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HTTP + * json: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/json + * utf8-string: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/utf8-string + * mime: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mime + +('cabal install' will take care of chasing these down for you, btw..) + += Authentication = + +When using this API binding to build your own Twitter applications, +authentication is required ... + += Feedback / question = + +Please send them to sof@forkIO.com , and I'll try to respond to them +as best/quickly as possible. (Or, try to send a tweet 'sigbjorn_finne' :-) ) + +Enjoy.. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + + diff --git a/Web/Codec/Percent.hs b/Web/Codec/Percent.hs new file mode 100644 --- /dev/null +++ b/Web/Codec/Percent.hs @@ -0,0 +1,57 @@ +{- | + + Module : Web.Codec.Percent + Copyright : (c) 2008, Sigbjorn Finne + + Maintainer : sof@forkIO.com + + License : See the file LICENSE + + Status : Coded + + Codec for de/encoding URI strings via percent encodings + (cf. RFC 3986.) +-} +module Web.Codec.Percent where + +import Data.Char ( chr, isAlphaNum ) +import Numeric ( readHex, showHex ) + +getEncodedString :: String -> String +getEncodedString "" = "" +getEncodedString (x:xs) = + case getEncodedChar x of + Nothing -> x : getEncodedString xs + Just ss -> ss ++ getEncodedString xs + +getDecodedString :: String -> String +getDecodedString "" = "" +getDecodedString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : getDecodedString xs + Just (ch,xs1) -> ch : getDecodedString xs1 + +getEncodedChar :: Char -> Maybe String +getEncodedChar x + | isAlphaNum x || + x `elem` "-_.~" = Nothing + | xi < 0xff = Just ('%':showHex (xi `div` 16) (showHex (xi `mod` 16) "")) + | otherwise = -- ToDo: import utf8 lib + error "getEncodedChar: can only handle 8-bit chars right now." + where + xi :: Int + xi = fromEnum x + +getDecodedChar :: String -> Maybe (Char, String) +getDecodedChar str = + case str of + "" -> Nothing + (x:xs) + | x /= '%' -> Nothing + | otherwise -> do + case xs of + (b1:b2:bs) -> + case readHex [b1,b2] of + ((v,_):_) -> Just (Data.Char.chr v, bs) + _ -> Nothing + _ -> Nothing diff --git a/Web/Codec/URLEncoder.hs b/Web/Codec/URLEncoder.hs new file mode 100644 --- /dev/null +++ b/Web/Codec/URLEncoder.hs @@ -0,0 +1,33 @@ +{- + Codec for de/encoding form data shipped in URL query strings + or in POST request bodies. (application/x-www-form-urlencoded) + (cf. RFC 3986.) +-} +module Web.Codec.URLEncoder + ( encodeString + , decodeString + ) where + +import qualified Codec.Binary.UTF8.String as UTF8 ( encodeString ) +import Web.Codec.Percent ( getEncodedChar, getDecodedChar ) + +encodeString :: String -> String +encodeString str = go (UTF8.encodeString str) + where + go "" = "" + go (' ':xs) = '+':go xs + go ('\r':'\n':xs) = '%':'0':'D':'%':'0':'A':go xs + go ('\r':xs) = go ('\r':'\n':xs) + go ('\n':xs) = go ('\r':'\n':xs) + go (x:xs) = + case getEncodedChar x of + Nothing -> x : go xs + Just ss -> ss ++ go xs + +decodeString :: String -> String +decodeString "" = "" +decodeString ('+':xs) = ' ':decodeString xs +decodeString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : decodeString xs + Just (ch,xs1) -> ch : decodeString xs1 diff --git a/Web/Twitter.hs b/Web/Twitter.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter.hs @@ -0,0 +1,534 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Twitter +-- Description : Toplevel module for the Twitter API +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Toplevel module for the Twitter API, providing entry points +-- to the various REST endpoints that twitter.com offer up +-- +-------------------------------------------------------------------- +module Web.Twitter + ( getPublicTimeline -- :: TM [Status] + , getFriendsTimeline -- :: Maybe DateString -> Maybe String -> TM [Status] + , getUserTimeline -- :: Maybe String -> Maybe DateString -> Maybe String -> TM [Status] + + , showStatus -- :: String -> TM Status + , update -- :: String -> Maybe String -> TM () + , getReplies -- :: Maybe DateString -> Maybe String -> TM [Status] + , destroyStatus -- :: String -> TM () + + , getFriends -- :: Maybe String -> TM [Status] + , getFollowers -- :: Maybe String -> TM [Status] + , getUserInfo -- :: Maybe String -> Maybe String -> TM UserInfo + + , getDirectMessages -- :: Maybe DateString -> Maybe String -> TM [DirectMessage] + , getDirectMessagesSent -- :: Maybe DateString -> Maybe String -> TM [DirectMessage] + , sendDirectMessage -- :: UserId -> String -> TM DirectMessage + , destroyDirectMessage -- :: UserId -> TM () + + , createFriend -- :: UserId -> Maybe Bool -> TM User + , destroyFriend -- :: UserId -> TM () + , isFriendOf -- :: UserId -> UserId -> TM Bool + + , verifyCredentials -- :: TM User + , endSession -- :: TM () + , updateDeliveryDevice -- :: Maybe String -> TM () + + , ProfileColors(..) + , nullProfileColors + , updateProfileColors -- :: ProfileColors -> TM () + + , updateProfileImage -- :: FilePath -> TM () + , updateProfileBackgroundImage -- :: FilePath -> TM () + + , RateLimit(..) + , nullRateLimit + , getRateLimit -- :: TM RateLimit + + , ProfileInfo(..) + , nullProfileInfo + , updateProfile -- :: ProfileInfo -> TM () + + , getFavorites -- :: Maybe UserId -> TM [Status] + , createFavorite -- :: UserId -> TM User + , destroyFavorite -- :: UserId -> TM User + + , followUser -- :: UserId -> TM User + , leaveUser -- :: UserId -> TM User + + , createBlock -- :: UserId -> TM User + , destroyBlock -- :: UserId -> TM User + + , testCall -- :: TM String + + , setUpdateInterval + , setTwitterUser + , tweet + , stopUpdates + + ) where + +import Web.Twitter.Types hiding ( URLString ) +import Web.Twitter.Types.Import hiding ( showStatus ) +import Web.Twitter.Monad +import Web.Twitter.Fetch +import Web.Twitter.Post + +import Data.Maybe + +-- for the silly stuff below +import Control.Concurrent +import Control.Monad +import System.IO.Unsafe +import System.Time +import System.Locale + +-------------------------------------------------- +-- A bit of persistent fun to enable use from within GHCi +-- +twitter_user :: MVar (Maybe AuthUser) +twitter_user = unsafePerformIO (newMVar Nothing) + +twitter_update_info :: MVar (Maybe Int,Maybe ThreadId) +twitter_update_info = unsafePerformIO (newMVar (Nothing,Nothing)) + +setUpdateInterval :: IO () +setUpdateInterval = do + putStr "Check updates every X mins: " + l <- getLine + case reads l of + ((v,_):_) -> do + (_,b) <- readMVar twitter_update_info + -- kill old worker thread and start up new. + case b of + Nothing -> return () + Just t -> catch (killThread t) (\ _ -> return ()) + t <- forkIO (updateChecker v Nothing) + modifyMVar_ twitter_update_info (\ _ -> return (Just v, Just t)) + _ -> putStrLn ("Unable to parse minute: " ++ show l) + where + updateChecker everyMins mbSince = do + threadDelay (everyMins * 1000000 * 60) + x <- readMVar twitter_user + case x of + Nothing -> updateChecker everyMins mbSince + Just au -> do + n <- nowDateString + ls <- runTM au (getFriendsTimeline mbSince Nothing) + when (not $ null ls) (putStrLn "") + mapM_ (\ s -> putStrLn (userScreenName (statusUser s) ++ ": " ++ statusText s)) ls + updateChecker everyMins (Just n) + +stopUpdates :: IO () +stopUpdates = do + (a,b) <- readMVar twitter_update_info + -- kill old worker thread and start up new. + case b of + Nothing -> return () + Just t -> catch (killThread t) (\ _ -> return ()) + modifyMVar_ twitter_update_info (\ _ -> return (a,Nothing)) + +setTwitterUser :: IO () +setTwitterUser = do + putStr "User name: " + u <- getLine + putStr "User password: " + p <- getLine + modifyMVar_ twitter_user (\ _ -> return $ Just (AuthUser u p)) + +tweet :: String -> IO () +tweet s = do + r <- readMVar twitter_user + case r of + Nothing -> do + putStrLn "Unable to tweet, no user set - run 'setTwitterUser'" + return () + Just au -> do + runTM au (update s Nothing) + return () + +nowDateString :: IO String +nowDateString = do + c <- getClockTime + return (formatDateString $ toUTCTime c) + +formatDateString :: CalendarTime -> String +formatDateString ct = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" ct + +-------------------------------------------------- + +-- | @getPublicTimeline@ returns the 20 most recent statuses from non-protected +-- users who have set a custom user icon +getPublicTimeline :: TM [Status] +getPublicTimeline = withAuth False $ restCall pub [] >>= readResult "getPublicTimeline" + where pub = "public_timeline.json" + +-- | @getFriendsTimeline mbSince mbSinceId@ returns the 20 most recent statuses posted by +-- the authenticating user and that user's friends. Optionally constrained by start date +-- or a status ID. +getFriendsTimeline :: Maybe DateString -> Maybe String -> TM [Status] +getFriendsTimeline since sinceId = withAuth True $ + restCall fri + (mbArg "since" since $ + mbArg "since_id" sinceId []) >>= readResult "getFriendsTimeline" + where + fri = "friends_timeline.json" + +-- | @getUserTimeline mbId mbSince mbSinceId@ returns the 20 most recent statuses +-- posted from the authenticating user. It's also possible to request another user's +-- timeline via the id parameter below. +getUserTimeline :: Maybe String -> Maybe DateString -> Maybe String -> TM [Status] +getUserTimeline mbId since sinceId = withAuth True $ + restCall usr + (mbArg "id" mbId $ + mbArg "since" since $ + mbArg "since_id" sinceId []) >>= readResult "getUserTimeline" + where + usr = "user_timeline.json" + +-- | @showStatus id@ returns a single status, specified by the @id@ parameter. +-- The status's author will be returned inline. +showStatus :: String -> TM Status +showStatus i = withAuth True $ restCall usr [] >>= readResult "showStatus" + where + usr = "show/" ++ i ++ ".json" + +-- | @update text mbReplyToId@ updates the authenticating user's status to @text@. +update :: String -> Maybe String -> TM () +update txt mbRep = withAuth True $ postMethod $ do + restCall upd + (arg "status" txt $ + mbArg "in_reply_to_status_id" mbRep []) + return () + where + upd = "update.json" + +-- | @getReplies mbSince mbSinceId@ returns the 20 most recent +-- \@replies (status updates prefixed with \@username) for the +-- authenticating user. +getReplies :: Maybe DateString -> Maybe String -> TM [Status] +getReplies since sinceId = withAuth True $ + restCall rep + (mbArg "since" since $ + mbArg "since_id" sinceId []) >>= readResult "getReplies" + where + rep = "replies.json" + +-- | @destroyStatus id@ destroys the status specified by the @id@ +-- parameter. The authenticating user must be the author of the +-- specified status. +destroyStatus :: String -> TM () +destroyStatus i = withAuth True $ postMethod $ restCall des [] >> return () + where + des = "destroy/" ++ i ++ ".json" + +-- | @getFriends mbId@ returns up to 100 of the authenticating +-- user's friends who have most recently updated, each with current +-- status inline. It's also possible to request another user's +-- recent friends list via the @mbId@ parameter. +getFriends :: Maybe String -> TM [Status] +getFriends mbId = withAuth True $ restCall fri [] >>= readResult "getFriends" + where + fri = + case mbId of + Nothing -> "friends.json" + Just i -> "friends/" ++ i ++ ".json" + +-- | @getFollowers mbId@ returns the authenticating user's followers, +-- each with current status inline. They are ordered by the order in which +-- they joined Twitter (this is going to be changed). +getFollowers :: Maybe String -> TM [Status] +getFollowers mbId = withAuth True $ restCall folly [] >>= readResult "getFollowers" + where + folly = maybe "followers.json" (\ i -> "followers/" ++ i ++ ".json") mbId + +-- | @getUserInfo mbId mbEmail@ returns extended information of a given user, +-- specified by ID or screen name as per the @mbId@ parameter below. +-- This information includes design settings, so third party developers +-- can theme their widgets according to a given user's preferences. +-- You must be properly authenticated to request the page of a protected user. +getUserInfo :: Maybe String -> Maybe String -> TM UserInfo +getUserInfo mbId mbEmail = withBase user_base_url $ withAuth True $ + restCall folly + (mbArg "email" mbEmail []) >>= readResult "getUserInfo" + where + folly = maybe "show.json" (\i -> "show/" ++ i ++ ".json") mbId + +-- | @getDirectMesssages mbSince mbSinceId@ returns a list of the 20 most +-- recent direct messages sent to the authenticating user. +getDirectMessages :: Maybe DateString -> Maybe String -> TM [DirectMessage] +getDirectMessages since sinceId = withBase top_base_url $ withAuth True $ + restCall rep + (mbArg "since" since $ + mbArg "since_id" sinceId []) >>= readResult "getDirectMessages" + where + rep = "direct_messages.json" + +-- | @getDirectMessagesSent mbSince mbSinceId@ returns a list of the 20 most +-- recent direct messages sent by the authenticating user. +getDirectMessagesSent :: Maybe DateString -> Maybe String -> TM [DirectMessage] +getDirectMessagesSent since sinceId = withBase top_base_url $ withAuth True $ + restCall rep + (mbArg "since" since $ + mbArg "since_id" sinceId []) >>= readResult "getDirectMessagesSent" + where + rep = "direct_messages/sent.json" + +-- | @sendDirectMessage userId text@ sends a new direct message to +-- the specified user from the authenticating user. +-- Requires both the @user@ and @text@ parameters. +-- Returns the sent message in the requested format when successful. +sendDirectMessage :: UserId -> String -> TM DirectMessage +sendDirectMessage userId txt = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir + (arg "user" userId $ arg "text" txt []) >>= readResult "sendDirectMessage" + where + dir = "direct_messages/new.json" + +-- @destroyDirectMessage id@ destroys the direct message specified +-- in the required ID parameter. The authenticating user must be the +-- recipient of the specified direct message. +destroyDirectMessage :: UserId -> TM () +destroyDirectMessage i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >> return () + where + des = "direct_messages/destroy/" ++ i ++ ".json" + +-- | @createFriend id mbFollow@ befriends the user specified in the @id@ +-- parameter as the authenticating user. Returns the befriended user in +-- the requested format when successful. Returns a string describing the +-- failure condition when unsuccessful. +createFriend :: UserId -> Maybe Bool -> TM User +createFriend i mbFollow = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir + (mbArg "user" (fmap toB mbFollow) []) >>= readResult "createFriend" + where + dir = "friendships/create/" ++ i ++ ".json" + +-- | @destroyFriend i@ discontinues friendship with the user specified in +-- the @id@ parameter as the authenticating user. Returns the un-friended user +-- in the requested format when successful. Returns a string describing the +-- failure condition when unsuccessful. +destroyFriend :: UserId -> TM User +destroyFriend i = withBase top_base_url $ withAuth True $ postMethod $ + restCall des [] >>= readResult "destroyFriend" + where + des = "friendships/destroy/" ++ i ++ ".json" + +-- | @isFriendOf userA userB@ tests if a friendship exists between two users. +isFriendOf :: UserId -> UserId -> TM Bool +isFriendOf ua ub = withBase top_base_url $ withAuth True $ + restCall fr (arg "user_a" ua $ arg "user_b" ub []) >>= readResult "isFriendOf" + where + fr = "friendships/exists.json" + +toB :: Bool -> String +toB False = "false" +toB True = "true" + +-- | @verifyCredentials@ returns an HTTP 200 OK response code and a +-- representation of the requesting user if authentication was successful; +-- returns a 401 status code and an error message if not. +-- Use this method to test if supplied user credentials are valid. +verifyCredentials :: TM User +verifyCredentials = withBase acc_base_url $ withAuth True $ + restCall acc [] >>= readResult "verifyCredentials" + where + acc = "verify_credentials.json" + +-- | @endSession@ ends the session of the authenticating user, +-- returning a null cookie. Use this method to sign users out of +-- client-facing applications like widgets. +endSession :: TM () +endSession = withBase acc_base_url $ withAuth True $ postMethod $ + restCall acc [] >> return () + where + acc = "end_session" + +-- | @updateDeliveryService mbServ@ sets which device Twitter delivers +-- updates to for the authenticating user. Sending @Nothing@ as the +-- device parameter will disable IM(@im@) or SMS(@sms@) updates. +updateDeliveryDevice :: Maybe String -> TM () +updateDeliveryDevice mbS = withBase acc_base_url $ withAuth True $ postMethod $ + restCall acc (arg "device" (fromMaybe "none" mbS) []) >> return () + where + acc = "update_delivery_device.json" + +data ProfileColors + = ProfileColors + { profileTextColor :: Maybe ColorString + , profileBackColor :: Maybe ColorString + , profileLinkColor :: Maybe ColorString + , profileSidebarFill :: Maybe ColorString + , profileSidebarBorder :: Maybe ColorString + } + +nullProfileColors + = ProfileColors + { profileTextColor = Nothing + , profileBackColor = Nothing + , profileLinkColor = Nothing + , profileSidebarFill = Nothing + , profileSidebarBorder = Nothing + } + +-- | @updateProfileColors pc@ sets one or more hex values that control the +-- color scheme of the authenticating user's profile page on @twitter.com@. +updateProfileColors :: ProfileColors -> TM () +updateProfileColors pc = withBase acc_base_url $ withAuth True $ postMethod $ + restCall acc + (mbArg "profile_background_color" (profileBackColor pc) $ + mbArg "profile_text_color" (profileTextColor pc) $ + mbArg "profile_link_color" (profileLinkColor pc) $ + mbArg "profile_sidebar_fill_color" (profileSidebarFill pc) $ + mbArg "profile_sidebar_border_color" (profileSidebarFill pc) $ + []) >> return () + where + acc = "update_profile_colors.json" + +-- | @updateProfileImage imgFile@ updates the authenticating user's profile image. +-- Expects raw multipart data, not a URL to an image. +updateProfileImage :: FilePath -> TM () +updateProfileImage fp = withBase acc_base_url $ withAuth True $ postMethod $ do + let pr = + addNameFile "image" fp Nothing $ + newPostRequest "img_upload" + (url_q, hs, bod) <- liftIO (toRequest pr (Just PostFormData)) + let u = appendQueryArgs acc url_q + (_,_,xs) <- postCall u hs bod [] + return () + where + acc = "update_profile_image.json" + +-- | @updateProfileBackgroundImage imgFile@ udates the authenticating +-- user's profile background image. Expects raw multipart data, not a +-- URL to an image. +updateProfileBackgroundImage :: FilePath -> TM () +updateProfileBackgroundImage fp = withBase acc_base_url $ withAuth True $ postMethod $ do + let pr = + addNameFile "image" fp Nothing $ + newPostRequest "img_upload" + (url_q, hs, bod) <- liftIO (toRequest pr (Just PostFormData)) + let u = appendQueryArgs acc url_q + (_,_,xs) <- postCall u hs bod [] + return () + where + acc = "update_profile_background_image.json" + +-- | @getRateLimit@ returns the remaining number of API requests available +-- to the requesting user before the API limit is reached for the current +-- hour. Calls to @getRateLimit@ do not count against the rate limit. +-- If authentication credentials are provided, the rate limit status for +-- the authenticating user is returned. Otherwise, the rate limit status +-- for the requester's IP address is returned. +getRateLimit :: TM RateLimit +getRateLimit = withBase acc_base_url $ withAuth True $ do + restCall acc [] >>= readResult "getRateLimit" + where + acc = "rate_limit_status.json" + +appendQueryArgs x "" = x +appendQueryArgs x y = x ++ '?':y + +data ProfileInfo + = ProfileInfo + { profileInfoName :: Maybe String + , profileInfoEmail :: Maybe String + , profileInfoURL :: Maybe URLString + , profileInfoLocation :: Maybe String + , profileInfoDescription :: Maybe String + } + +nullProfileInfo :: ProfileInfo +nullProfileInfo = ProfileInfo + { profileInfoName = Nothing + , profileInfoEmail = Nothing + , profileInfoURL = Nothing + , profileInfoLocation = Nothing + , profileInfoDescription = Nothing + } + +-- | @updateProfile profileInfo@ sets values that users are able to +-- set under the "Account" tab of their settings page. Only the parameters +-- specified will be updated; to only update the "name" attribute, for +-- example, only include that as a @Just@ value in the @ProfileInfo@ parameter. +updateProfile :: ProfileInfo -> TM () +updateProfile pi = withBase acc_base_url $ withAuth True $ postMethod $ + restCall acc + (mbArg "name" (profileInfoName pi) $ + mbArg "email" (profileInfoEmail pi) $ + mbArg "url" (profileInfoURL pi) $ + mbArg "location" (profileInfoLocation pi) $ + mbArg "description" (profileInfoDescription pi) $ + []) >> return () + where + acc = "update_profile.json" + + +-- | @getFavorites mbId@ returns the 20 most recent favorite statuses +-- for the authenticating user or user specified by the @mbId@ parameter. +getFavorites :: Maybe UserId -> TM [Status] +getFavorites i = withBase top_base_url $ withAuth True $ + restCall acc [] >>= readResult "getFavorites" + where + acc = maybe "favorites.json" (\ x -> "favorites/"++x++".json") i + +-- | @createFavorite id@ favorites the status specified in the @id@ +-- parameter as the authenticating user. +-- Returns the favorite status when successful. +createFavorite :: UserId -> TM User +createFavorite i = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir [] >>= readResult "createFavorite" + where + dir = "favorites/create/"++i++".json" + +-- | @destroyFavorite id@ un-favorites the status specified in +-- the ID parameter as the authenticating user. +-- Returns the un-favorited status in the requested format when successful. +destroyFavorite :: UserId -> TM User +destroyFavorite i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >>= readResult "destroyFavorite" + where + des = "favorites/destroy/" ++ i ++ ".json" + +-- | @followUser id@ enables notifications for updates from the +-- specified user to the authenticating user. Returns the specified +-- user when successful. +followUser :: UserId -> TM User +followUser i = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir [] >>= readResult "followUser" + where + dir = "notifications/follow/"++i++".json" + +-- | @leaveUser id@ disables notifications for updates from the +-- specified user to the authenticating user. +-- Returns the specified user when successful. +leaveUser :: UserId -> TM User +leaveUser i = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir [] >>= readResult "leaveUser" + where + dir = "notifications/leave/"++i++".json" + +-- | @createBlock id@ blocks the user specified in the @id@ parameter +-- as the authenticating user. Returns the blocked user. +createBlock :: UserId -> TM User +createBlock i = withBase top_base_url $ withAuth True $ postMethod $ + restCall dir [] >>= readResult "createBlock" + where + dir = "blocks/create/"++i++".json" + +-- | @destroyBlock id@ un-blocks the user specified in the @id@ parameter +-- as the authenticating user. Returns the un-blocked user. +destroyBlock :: UserId -> TM User +destroyBlock i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >>= readResult "destroyBlock" + where + des = "blocks/destroy/" ++ i ++ ".json" + +-- | @testCall@ returns the string "ok" in the requested format +-- with a 200 OK HTTP status code. +testCall :: TM String +testCall = withBase top_base_url $ withAuth False $ restCall "help/test.json" [] >>= readResult "testCall" diff --git a/Web/Twitter/Fetch.hs b/Web/Twitter/Fetch.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Fetch.hs @@ -0,0 +1,179 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Twitter.Fetch +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Simple GET\/de-ref of URLs; abstracting out networking backend\/package. +-- +module Web.Twitter.Fetch + ( readContentsURL + , readUserContentsURL + + , postContentsURL + + , URLString + , AuthUser(..) + , nullAuthUser + , Cookie + ) where + +--import Network.Curl +import Network.Browser +import Network.HTTP +import Network.URI + +type URLString = String + +data AuthUser + = AuthUser { authUserName :: String + , authUserPass :: String + } + +nullAuthUser :: AuthUser +nullAuthUser = AuthUser + { authUserName = "" + , authUserPass = "" + } + +readContentsURL :: URLString -> IO String +readContentsURL u = do + req <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let nullHandler _ = return () + (_u, resp) <- browse $ setOutHandler nullHandler >> request req + case rspCode resp of + (2,_,_) -> return (rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + +{- Curl version: +readContentsURL :: URLString -> IO String +readContentsURL u = do + let opts = [ CurlFollowLocation True + ] + (_,xs) <- curlGetString u opts + return xs +-} + +readUserContentsURL :: Maybe AuthUser -> Bool -> Bool -> URLString -> [(String,String)] -> IO ([(String,String)], String) +readUserContentsURL mbU doRedir isHead us hdrs = do -- readContentsURL u + let hs = + case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders hdrs) of + Left{} -> [] + Right xs -> xs + req0 <- + case parseURI us of + Nothing -> fail ("ill-formed URL: " ++ us) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $ + req0{ rqMethod=if isHead then HEAD else GET + , rqHeaders= hs + , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing} + } + let nullHandler _ = return () + (u, resp) <- browse $ do + setOutHandler nullHandler + case mbU of + Nothing -> return () + Just usr -> do + setAllowRedirects doRedir + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) + +-- setAllowBasicAuth True +-- setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) +{- + addAuthority AuthBasic{ auUsername = userName usr + , auPassword = userPass usr + , auRealm = "" + , auSite = nullURI{uriPath="/"} + } +-} + request req + case rspCode resp of + (2,_,_) -> return (map toP (rspHeaders resp), rspBody resp) + (3,_,_) | not doRedir -> return (map toP (rspHeaders resp), rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + + +postContentsURL :: Maybe AuthUser + -> URLString + -> [(String,String)] + -> [Cookie] + -> String + -> IO ([Cookie],[(String,String)], String) +postContentsURL mbU u hdrs csIn body = do + let hs = + case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders hdrs) of + Left{} -> [] + Right xs -> xs + req0 <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $ + req0{ rqMethod=POST + , rqBody=body + , rqHeaders= hs + , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing} + } +-- print req -- ,body) + let nullHandler _ = return () + ((_,rsp),cs) <- browse $ do + setOutHandler nullHandler + setAllowRedirects True + setCookies csIn + case mbU of + Nothing -> return () + Just usr -> do + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) + + v <- request req + ls <- getCookies + return (v,ls) + case rspCode rsp of + (2,_,_) -> return (cs,map toP (rspHeaders rsp), rspBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u ++ show (rspBody rsp)) + +toP (Header k v) = (show k, v) + +addDefaultHeaders :: [(String,String)] -> [(String,String)] +addDefaultHeaders hs = + case lookup "User-Agent" hs of + Nothing -> ("User-Agent", "hs-mw-utils"):hs + _ -> hs + +{- Curl versions: +readUserContentsURL :: User -> URLString -> IO String +readUserContentsURL u url = do + let opts = [ CurlHttpAuth [HttpAuthAny] + , CurlUserPwd (authUserName u ++ + case userPass u of {"" -> ""; p -> ':':p }) + , CurlFollowLocation True + ] + (_,xs) <- curlGetString url opts + return xs + +postContentsURL :: URLString -> [(String,String)] -> String -> IO String +postContentsURL u hdrs body = do + let opts = [ CurlCustomRequest "POST" + , CurlFollowLocation True + , CurlPost True + , CurlPostFields [body] + , CurlHttpTransferDecoding False + ] ++ [CurlHttpHeaders (map ( \ (x,y) -> (x ++ ':':y)) hdrs)] + rsp <- curlGetResponse u opts + case respStatus rsp `div` 100 of + 2 -> return (respBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u) + +-} diff --git a/Web/Twitter/MIME.hs b/Web/Twitter/MIME.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/MIME.hs @@ -0,0 +1,117 @@ +module Web.Twitter.MIME where + +import System.IO +import System.Random +import Numeric ( showHex ) +import Data.List ( intercalate ) + +import Codec.MIME.Type as MIME + +uploadFileType :: String -> MIME.Type +uploadFileType bou = MIME.Type + { mimeType = Multipart FormData + , mimeParams = [("boundary", bou)] + } + +mixedType :: IO (MIMEValue, String) +mixedType = do + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" + return (nullMIMEValue + { mime_val_type = MIME.Type { mimeType = Multipart Mixed + , mimeParams = [("boundary", boundary)] + } + }, boundary) + +uploadFile :: String -> FilePath -> IO MIMEValue +uploadFile nm fp = do +{- + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" +-} + let file_disp = + Disposition + { dispType = DispFormData + , dispParams = [ Name nm, Filename fp ] + } + h <- openBinaryFile fp ReadMode + ls <- hGetContents h + let fileValue = + nullMIMEValue + { mime_val_type = Type{mimeType=Text "plain", mimeParams=[]} + , mime_val_disp = Just file_disp + , mime_val_content = Single ls + , mime_val_headers = [ ("Content-Transfer-Encoding", "binary") + , ("Content-Length", show (length ls)) + ] + , mime_val_inc_type = True + } + return fileValue -- MIMEValue +{- + { mime_val_type = uploadFileType boundary + , mime_val_disp = Nothing + , mime_val_content = Multi [fileValue] + } +-} +showMIMEValue :: String -> MIMEValue -> ([(String,String)], String) +showMIMEValue m mv = + let marker = + case mimeType (mime_val_type mv) of + Multipart{} -> + case lookup "boundary" (mimeParams (mime_val_type mv)) of + Just x -> crnl ++ '-':'-':x + _ -> m + _ -> m + in + ( withType $ withDisp (mime_val_headers mv) + , (if True || null m then (crnl++) else (\x -> m ++ crnl ++ x)) + (showMIMEContent marker (mime_val_content mv)) + ) + where + withType + | mime_val_inc_type mv = (("Content-Type", showType (mime_val_type mv)):) + | otherwise = id + + withDisp = + case mime_val_disp mv of + Nothing -> id + Just d -> (("Content-Disposition", showDisposition d):) + +showMIMEContent :: String -> MIMEContent -> String +showMIMEContent _marker (Single s) = s +showMIMEContent marker (Multi ms) = + concat (map (s.(showMIMEValue marker)) ms) ++ marker ++ "--" + where + s (hs,v) = marker ++ crnl ++ + intercalate crnl (map (\ (a,b) -> (a ++ ':':' ':b)) hs) ++ crnl ++ v + +crnl :: String +crnl = "\r\n" + +showDisposition :: Disposition -> String +showDisposition d = + showDispType (dispType d) ++ + (concat $ map showDispParam (dispParams d)) + +showDispType :: DispType -> String +showDispType dt = + case dt of + DispInline -> "inline" + DispAttachment -> "attachment" + DispFormData -> "form-data" + DispOther x -> x + +showDispParam :: DispParam -> String +showDispParam dp = ';':' ': + case dp of + Name x -> "name="++show x + Filename x -> "filename=" ++ show x + CreationDate s -> "creation-date=" ++ show s + ModDate s -> "modification-date=" ++ show s + ReadDate s -> "read-date=" ++ show s + MIME.Size x -> "size=" ++ show x + OtherParam a b -> a ++ '=':show b + + diff --git a/Web/Twitter/Monad.hs b/Web/Twitter/Monad.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Monad.hs @@ -0,0 +1,199 @@ +module Web.Twitter.Monad + ( TM + , TMEnv(..) + + , withEnv + , withUser + , withCount + , withPage + , withPageCount + , withAuth + , withBase + + , getEnv + , getUser + , getCount + , getPage + , getPageCount + , getBase + , getPostFlag + + , runTwitter + , runTM + + , liftIO + + , api_base + , user_base_url + , top_base_url + , acc_base_url +-- , buildUrl + + , Result(..) + , decodeStrict + + , mbArg + , arg + , restCall + , postCall + , readResult + , postMethod + + ) where + +import Text.JSON +import Text.JSON.Types + +import Control.Monad +import Data.List + +import Web.Codec.URLEncoder +import Web.Twitter.Fetch + +api_base :: URLString +api_base = "http://www.twitter.com/statuses/" + +top_base_url :: URLString +top_base_url = "http://www.twitter.com/" + +user_base_url :: URLString +user_base_url = "http://www.twitter.com/users/" + +acc_base_url :: URLString +acc_base_url = "http://www.twitter.com/account/" + +{- +buildUrl :: (URLString -> IO a) -> URLString -> TM a +buildUrl f u = do + mbc <- getCount + liftIO (f (case mbc of { Nothing -> u ; Just c -> u++"?count="++show c})) +-} + +mbArg :: String -> Maybe String -> [(String,String)] -> [(String,String)] +mbArg _ Nothing xs = xs +mbArg f (Just x) xs = (f,x):xs + +arg :: String -> String -> [(String,String)] -> [(String,String)] +arg f x xs = (f,x):xs + +restCall :: String -> [(String,String)] -> TM String +restCall u args = do + mbc <- getCount + mbp <- getPage + let q = maybe id (\ x -> (("count="++show x):)) mbc $ + maybe id (\ x -> (("page="++show x):)) mbp $ + (map (\ (x,y) -> x ++ '=':encodeString y) args) + b <- getBase + let url = b++ u ++ case q of { [] -> "" ; xs -> '?':intercalate "&" xs} + isA <- getUser + isP <- getPostFlag + case isA of + Nothing -> liftIO (readContentsURL url) + Just au + | isP -> liftIO (postContentsURL (Just au) url [] [] "" >>= \ (a,b,c) -> return c) + | otherwise -> liftIO (readUserContentsURL (Just au) True False{-is HEAD-} url [] >>= \ (a,b) -> return b) + +postCall :: String -> [(String,String)] -> String -> [(String,String)] -> TM ([Cookie],[(String,String)], String) +postCall u hs bod args = do + mbc <- getCount + mbp <- getPage + let q = maybe id (\ x -> (("count="++show x):)) mbc $ + maybe id (\ x -> (("page="++show x):)) mbp $ + (map (\ (x,y) -> x ++ '=':encodeString y) args) + b <- getBase + let url = b++ u ++ case q of { [] -> u ; xs -> '?':u ++ intercalate "&" xs} + isA <- getUser + isP <- getPostFlag + liftIO (postContentsURL isA url hs [] bod) + +readResult :: JSON a => String -> String -> TM a +readResult loc s = + case decode s of + Ok e -> return e + Error e -> + case s of + ('"':xs) -> -- " strip quotes and try again..won't hurt.. + readResult loc (init xs) + _ -> liftIO $ ioError $ userError (loc ++ ':':' ':e) + +data TMEnv + = TMEnv + { tmUser :: Maybe AuthUser + , tmBase :: URLString + , tmCount :: Maybe Int + , tmPage :: Maybe Int + , tmPost :: Bool + } + +nullEnv :: TMEnv +nullEnv = TMEnv + { tmUser = Nothing + , tmBase = api_base + , tmCount = Nothing + , tmPage = Nothing + , tmPost = False + } + +newtype TM a = TM {unTM :: TMEnv -> IO a} + +instance Monad TM where + return x = TM $ \ _ -> return x + m >>= k = TM $ \ env -> do + v <- unTM m env + unTM (k v) env + +withEnv :: (TMEnv -> TMEnv) -> TM a -> TM a +withEnv fenv k = TM $ \ env -> (unTM k) (fenv env) + +withUser :: AuthUser -> TM a -> TM a +withUser u k = withEnv (\ e -> e{tmUser=Just u}) k + +withCount :: Int -> TM a -> TM a +withCount c k = withEnv (\e -> e{tmCount=Just c}) k + +withPage :: Int -> TM a -> TM a +withPage c k = withEnv (\e -> e{tmPage=Just c}) k + +withBase :: URLString -> TM a -> TM a +withBase u t = withEnv (\ e -> e{tmBase=u}) t + +withPageCount :: Maybe Int -> Maybe Int -> TM a -> TM a +withPageCount mbP mbC k = withEnv (\e -> e{tmPage=mbP,tmCount=mbC}) k + +withAuth :: Bool -> TM a -> TM a +withAuth False tm = withEnv (\e -> e{tmUser=Nothing}) tm +withAuth _ tm = tm + +postMethod :: TM a -> TM a +postMethod (TM x) = TM $ \ env -> x env{tmPost=True} + +getPostFlag :: TM Bool +getPostFlag = getEnv >>= return.tmPost + +getUser :: TM (Maybe AuthUser) +getUser = TM $ \ env -> return (tmUser env) + +getEnv :: TM TMEnv +getEnv = TM $ \ env -> return env + +getCount :: TM (Maybe Int) +getCount = TM $ \ env -> return (tmCount env) + +getPage :: TM (Maybe Int) +getPage = TM $ \ env -> return (tmPage env) + +getPageCount :: TM (Maybe Int, Maybe Int) +getPageCount = TM $ \ env -> return (tmCount env, tmPage env) + +getBase :: TM URLString +getBase = TM $ \ env -> return (tmBase env) + +liftIO :: IO a -> TM a +liftIO a = TM $ \ _ -> a + +runTwitter :: Maybe AuthUser -> URLString -> TM a -> IO a +runTwitter mbu b dm = (unTM dm) nullEnv{tmUser=mbu,tmBase=b} + +runTM :: AuthUser -> TM a -> IO a +runTM user a = runTwitter (Just user) api_base a + diff --git a/Web/Twitter/Post.hs b/Web/Twitter/Post.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Post.hs @@ -0,0 +1,206 @@ +module Web.Twitter.Post where + +import Codec.MIME.Type as MIME +import Codec.MIME.Parse as MIME +import Web.Twitter.MIME +import Web.Codec.URLEncoder + +import Data.List +import System.Random +import Numeric + +-- ease the working with POST requests and their +-- outgoing payloads. + +data PostReq + = PostReq + { prName :: String + , prVals :: [PostParam] + } + +data PostKind + = PostQuery + | PostWWWForm + | PostFormData + +newPostRequest :: String -> PostReq +newPostRequest s = PostReq{prName=s,prVals=[]} + +testRequest :: PostReq + -> Maybe PostKind + -> IO () +testRequest a b = do + (as,bs,cs) <- toRequest a b + putStrLn ("URL query portion: " ++ as) + putStrLn (unlines $ map (\ (k,v) -> k ++ ':':' ':v) bs) + putStrLn "" + putStrLn cs + + +toRequest :: PostReq + -> Maybe PostKind + -> IO (String, [(String,String)], String) +toRequest pr mbKind = + case mbKind of + Nothing -> + case filter isPostFile (prVals pr) of + (_:_) -> toRequest pr (Just PostFormData) + _ -> toRequest pr (Just PostWWWForm) + Just PostQuery -> + case partition isPostFile (prVals pr) of + (ls@(_:_),bs) -> do + putStrLn ("toRequest: POST request contains " ++ + shows (length ls) (" files; unable to represent as query string")) + putStrLn ("Defaulting to multiform/form-data instead") + toRequest pr{prVals=bs++ls} (Just PostFormData) + _ -> + let + (body_enc, xs) = partition mustBeBody (prVals pr) + body + | null body_enc = "" + | otherwise = toAmpString body_enc + in + return ( toAmpString xs + , ("Content-Length", show (length body)) : + if null body_enc + then [] + else [ ("Content-Type", "application/x-www-form-urlencoded") ] + , body + ) + Just PostWWWForm -> + case partition isPostFile (prVals pr) of + (ls@(_:_),bs) -> do + putStrLn ("toRequest: POST request contains " ++ + shows (length ls) (" files; unable to represent as application/x-www-form-urlencoded")) + putStrLn ("Defaulting to multiform/form-data instead") + toRequest pr{prVals=bs++ls} (Just PostFormData) + _ -> do + let + (qs, xs) = partition mustBeQuery (prVals pr) + body = toAmpString xs + return ( toAmpString qs + , [ ("Content-Type", "application/x-www-form-urlencoded") + , ("Content-Length", show (length body)) + ] + , body + ) + Just PostFormData -> do + let (qs, xs) = partition mustBeQuery (prVals pr) + mv <- toMIMEValue xs + let (hs,bod) = showMIMEValue "" mv + putStrLn bod + return ( toAmpString qs + , ("Content-Length", show (length bod)):hs + , bod + ) + +toAmpString :: [PostParam] -> String +toAmpString xs = + intercalate "&" $ + map (\ (PostNameValue n v _) -> encodeString n ++ '=':encodeString v) xs + +mustBeBody :: PostParam -> Bool +mustBeBody (PostNameValue _ _ (Just True)) = True +mustBeBody _ = False + +mustBeQuery :: PostParam -> Bool +mustBeQuery (PostNameValue _ _ (Just False)) = True +mustBeQuery _ = False + +-- | @addNameValue nm val req@ augments the request @req@ with a binding +-- for @(nm,val)@. Neither @nm@ nor @val@ are assumed encoded. It leaves it +-- until the serialization phase to fix on how to communicate the binding +-- for the POST request (i.e., via the query portion or in the request's body.) +addNameValue :: String -> String -> PostReq -> PostReq +addNameValue n v pr = pr{prVals=(PostNameValue n v Nothing):prVals pr} + +-- | @addQueryNameValue nm val req@ performs same function as @addNameValue@, +-- but adds the constraint that the binding must be transmitted as part of the query +-- portion of the URL it ends up going out via. +addQueryNameValue :: String -> String -> PostReq -> PostReq +addQueryNameValue n v pr = pr{prVals=(PostNameValue n v (Just False)):prVals pr} + +-- | @addQueryNameValue nm val req@ performs same function as @addNameValue@, +-- but adds the constraint that the binding must be transmitted as part of the +-- body of the POST request, forcing the payload to be of MIME type @application/x-www-form-urlencoded@ +addBodyNameValue :: String -> String -> PostReq -> PostReq +addBodyNameValue n v pr = pr{prVals=(PostNameValue n v (Just True)):prVals pr} + +-- | @addNameFile nm fb mbMimeType req@ augments the request @req@ with a binding +-- of name @nm@ to the local file @fb@. It will be slurped in and included in the +-- POST request, as part of a multi-part payload. +addNameFile :: String -> FilePath -> Maybe String -> PostReq -> PostReq +addNameFile nm fp mbTy pr = pr{prVals=(PostFile nm fp mbTy):prVals pr} + +data PostParam + = PostNameValue String -- name + String -- value (assume: un-encoded) + (Maybe Bool) -- Just True => must be in query; Just False => must be in body; Nothing => either way. + | PostFile String -- name + FilePath -- local file to post + (Maybe String) -- Just ty => use 'ty' as content-type + +isPostFile :: PostParam -> Bool +isPostFile PostFile{} = True +isPostFile _ = False + +toMIMEValue :: [PostParam] -> IO MIMEValue +toMIMEValue ps = do + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" + let (fs,ns) = + case partition isPostFile ps of + ([_],_) -> ([],ps) + xs -> xs + + fns <- mapM (fromPostParam boundary) ns + (mi,b) <- mixedType + ffs <- mapM (fromPostParam b) fs + let addM [] = [] + addM xs = [mi{mime_val_content=Multi xs}] + + return MIMEValue + { mime_val_type = MIME.Type{ mimeType = Multipart FormData + , mimeParams = [("boundary", boundary)] + } + , mime_val_disp = Nothing + , mime_val_content = Multi (fns ++ addM ffs) + , mime_val_inc_type = True + , mime_val_headers = [] + } + +fromPostParam :: String -> PostParam -> IO MIMEValue +fromPostParam _boundary (PostNameValue n v _mbQ) = + return MIMEValue + { mime_val_type = MIME.Type + { mimeType = Application "x-www-form-urlencoded" + , mimeParams=[] + } + , mime_val_disp = Just $ + Disposition { dispType = DispFormData + , dispParams = [Name n] + } + , mime_val_content = Single v -- (encodeString v) + , mime_val_headers = [] + , mime_val_inc_type = False + } +fromPostParam _boundary (PostFile nm fp mbTy) = do + ty <- + case mbTy of + Nothing -> getMIMEType fp + Just ty -> toMIMEType ty + mv <- uploadFile nm fp + return mv{mime_val_type=ty} + +toMIMEType :: String -> IO Type +toMIMEType tyStr = + case parseMIMEType tyStr of + Just t -> return t + _ -> return MIME.Type{mimeType=Text "plain",mimeParams=[]} + +getMIMEType :: String -> IO Type +getMIMEType x = + case parseMIMEType x of + Just t -> return t + _ -> return MIME.Type{mimeType=Application "octet-stream",mimeParams=[]} diff --git a/Web/Twitter/Types.hs b/Web/Twitter/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Types.hs @@ -0,0 +1,155 @@ +module Web.Twitter.Types where + +type ColorString = String +type DateString = String +type UserId = String +type URLString = String +type UserName = String + +data Format = FormatXML | FormatJSON | FormatRSS | FormatAtom + +data Status + = Status + { statusCreated :: DateString + , statusId :: String + , statusText :: String + , statusSource :: String + , statusTruncated :: Bool + , statusInReplyTo :: Maybe String + , statusInReplyToUser :: Maybe UserId + , statusFavorite :: Maybe Bool + , statusUser :: User + } + +nullStatus :: Status +nullStatus = Status + { statusCreated = "" + , statusId = "" + , statusText = "" + , statusSource = "" + , statusTruncated = False + , statusInReplyTo = Nothing + , statusInReplyToUser = Nothing + , statusFavorite = Nothing + , statusUser = nullUser + } + +data User + = User + { userId :: UserId + , userName :: UserName + , userScreenName :: String + , userDescription :: String + , userLocation :: String + , userProfileImageURL :: Maybe URLString + , userURL :: Maybe URLString + , userProtected :: Maybe Bool + , userFollowers :: Maybe Int + } + +nullUser :: User +nullUser = User + { userId = "" + , userName = "" + , userScreenName = "" + , userDescription = "" + , userLocation = "" + , userProfileImageURL = Nothing + , userURL = Nothing + , userProtected = Nothing + , userFollowers = Nothing + } + +data UserInfo + = UserInfo + { userInfoBackgroundTile :: Bool + , userInfoLinkColor :: ColorString + , userInfoBackground :: ColorString + , userInfoBackgroundImageURL :: URLString + , userInfoTextColor :: ColorString + , userInfoSidebarFill :: ColorString + , userInfoSidebarColor :: ColorString + , userInfoFollowers :: Int + , userInfoDescription :: String + , userInfoUTCOffset :: Int + , userInfoFavorites :: Int + , userInfoCreated :: DateString + , userInfoTimezone :: String + , userInfoImageURL :: URLString + , userInfoURL :: Maybe URLString + , userInfoStatusCount :: Int + , userInfoFriends :: Int + , userInfoScreenName :: UserName + , userInfoProtected :: Bool + , userInfoLocation :: String + , userInfoName :: UserName + , userInfoId :: UserId + } + +nullUserInfo :: UserInfo +nullUserInfo = UserInfo + { userInfoBackgroundTile = False + , userInfoLinkColor = "" + , userInfoBackground = "" + , userInfoBackgroundImageURL = "" + , userInfoTextColor = "" + , userInfoSidebarFill = "" + , userInfoSidebarColor = "" + , userInfoFollowers = 0 + , userInfoDescription = "" + , userInfoUTCOffset = 0 + , userInfoFavorites = 0 + , userInfoCreated = "" + , userInfoTimezone = "" + , userInfoImageURL = "" + , userInfoURL = Nothing + , userInfoStatusCount = 0 + , userInfoFriends = 0 + , userInfoScreenName = "" + , userInfoProtected = False + , userInfoLocation = "" + , userInfoName = "" + , userInfoId = "" + } + +data DirectMessage + = DirectMessage + { directRecipient :: Maybe User + , directSender :: Maybe User + , directSenderId :: UserId + , directSenderName :: UserName + , directRecipientId :: UserId + , directRecipientName :: UserId + , directText :: String + , directId :: UserId -- mis-named, but works. + , directCreated :: DateString + } + +nullDirectMessage :: DirectMessage +nullDirectMessage = DirectMessage + { directRecipient = Nothing + , directSender = Nothing + , directSenderId = "" + , directSenderName = "" + , directRecipientId = "" + , directRecipientName = "" + , directText = "" + , directId = "" + , directCreated = "" + } + +data RateLimit + = RateLimit + { rateLimitResetSecs :: Integer + , rateLimitResetTime :: DateString + , rateLimitRemHits :: Integer + , rateLimitHourlyLimit :: Integer + } + +nullRateLimit :: RateLimit +nullRateLimit = RateLimit + { rateLimitResetSecs = 0 + , rateLimitResetTime = "" + , rateLimitRemHits = 0 + , rateLimitHourlyLimit = 0 + } diff --git a/Web/Twitter/Types/Import.hs b/Web/Twitter/Types/Import.hs new file mode 100644 --- /dev/null +++ b/Web/Twitter/Types/Import.hs @@ -0,0 +1,390 @@ +module Web.Twitter.Types.Import where + +import Web.Twitter.Types + +import Text.JSON +import Text.JSON.Types + +import Data.Char +import Data.Maybe +import Control.Monad + +import Debug.Trace + +data JM a = JM (String -> [(String,JSValue)] -> Result a) + +instance Monad JM where + return x = JM (\ _ _ -> return x) + (JM a) >>= k = JM $ \ loc env -> do + v <- a loc env + case k v of + (JM b) -> b loc env + +(-=>) :: a -> (b -> c) -> b -> (a,c) +(-=>) a b c = (a,b c) + +runJM :: String -> [(String,JSValue)] -> JM a -> Result a +runJM loc ps (JM a) = a loc ps + +liftR :: Result a -> JM a +liftR r = JM $ \ _ _ -> r + +getLoc :: JM String +getLoc = JM (\ l _ -> return l) + +getEnv :: JM [(String,JSValue)] +getEnv = JM (\ _ e -> return e) + +addToEnv :: [(String,JSValue)] -> JM a -> JM a +addToEnv ls (JM x) = JM $ \ loc ps -> x loc (ls++ps) + +get :: String -> JM String +get k = do -- trace (show ("g",k)) $ do + m <- getMb k + case m of + Just (JSString s) -> return (fromJSString s) + Just js -> return (showJSValue js "") + Nothing -> do + loc <- getLoc + fail (loc ++ ": missing value for key " ++ show k) + +getInt :: String -> JM Integer +getInt k = do + s <- get k + case reads s of + ((v,_):_) -> return v + _ -> do + loc <- getLoc + fail (loc ++ ": expected valid int, got " ++ show s) + +getMbS :: String -> JM (Maybe String) +getMbS k = do + v <- getMb k + case v of + Just (JSString s) -> return (Just (fromJSString s)) + _ -> return Nothing + +getMbI :: String -> JM (Maybe Int) +getMbI k = do + m <- getMb k + case m of + Just v -> {-trace (show ("i",v)) $ -}liftR (readJSON v) >>= return . Just + _ -> return Nothing + +getMbJ :: JSON a => String -> JM (Maybe a) +getMbJ k = do + v <- getMb k + case v of + Just j -> {-trace (show ("v",v)) $ -}liftR (readJSON j) >>= return . Just + _ -> return Nothing + +getJ :: JSON a => String -> JM a +getJ k = do + v <- getMb k + case v of + Just j -> liftR (readJSON j) + _ -> do + loc <- getLoc + fail (loc ++ ": unable to locate expected JSON field " ++ show k) + + +getMbB :: String -> JM (Maybe Bool) +getMbB k = do + v <- getMb k + case v of + Just (JSBool b) -> return (Just b) + _ -> return Nothing + +getMb :: String -> JM (Maybe JSValue) +getMb k = JM $ \ _loc env -> {-trace (show ("gm",k,env)) $ -}return (lookup k env) + +getB :: String -> JM Bool +getB v = do + b <- get v + case map toLower b of + "true" -> return True + "false" -> return False + "0" -> return False + "1" -> return True + bs -> do + loc <- getLoc + fail (loc ++ ": expected valid bool, got " ++ show bs) + +getJSON :: String -> JM JSValue +getJSON k = do + m <- getMb k + case m of + Just x -> return x + Nothing -> do + loc <- getLoc + fail (loc ++ ": missing value for key " ++ show k) + +showJS :: (a -> [(String, JSValue)]) -> a -> JSValue +showJS f x = JSObject (toJSObject (f x)) + +readJS :: String -> a -> (JM a) -> JSValue -> Result a +readJS _ n _ (JSArray []) = return n +readJS m n f (JSArray [x]) = readJS m n f x +readJS m _ f (JSObject (JSONObject pairs)) = runJM m pairs f +readJS m _ _ v = fail (m ++ ": unexpected JSON value " ++ show v) + +readJSONs :: JSON a => JSValue -> Result [a] +readJSONs ls@JSArray{} = readJSON ls +readJSONs x = readJSON (JSArray [x]) + +instance JSON User where + showJSON u = showJS showUser u + readJSON m = readJS "Web.Twitter.Types.User" nullUser readUser m + +instance JSON Status where + showJSON u = showJS showStatus u + readJSON m = readJS "Web.Twitter.Types.Status" nullStatus readStatus m + +instance JSON UserInfo where + showJSON u = showJS showUserInfo u + readJSON m = readJS "Web.Twitter.Types.UserInfo" nullUserInfo readUserInfo m + +instance JSON DirectMessage where + showJSON u = showJS showDM u + readJSON m = readJS "Web.Twitter.Types.DirectMessage" nullDirectMessage readDM m + +instance JSON RateLimit where + showJSON u = showJS showRateLimit u + readJSON m = readJS "Web.Twitter.Types.RateLimit" nullRateLimit readRateLimit m + +showUser :: User -> [(String, JSValue)] +showUser u = + [ "id" -=> str $ userId u + , "name" -=> str $ userName u + , "screen_name" -=> str $ userScreenName u + , "description" -=> str $ userDescription u + , "location" -=> str $ userLocation u + ] ++ catMaybes + [ mb "profile_image_url" str (userProfileImageURL u) + , mb "url" str (userURL u) + , mb "followers_count" int (userFollowers u) + , mb "protected" bool (userProtected u) + ] + +str :: String -> JSValue +str s = showJSON (JSONString s) +int :: Int -> JSValue +int i = showJSON (i::Int) +inte :: Integer -> JSValue +inte i = showJSON (i::Integer) +bool :: Bool -> JSValue +bool f = showJSON (JSBool f) + +js :: JSON a => a -> JSValue +js = showJSON + +readB :: Maybe String -> JM (Maybe Bool) +readB Nothing = return Nothing +readB (Just f) = return $ + case map toLower f of + "true" -> Just True + "false" -> Just False + "0" -> Just False + "1" -> Just True + _ -> Nothing + +mb :: String -> (a -> b) -> Maybe a -> Maybe (String, b) +mb _ _ Nothing = Nothing +mb t f (Just v) = Just (t,f v) + +readUser :: JM User +readUser = do + [i,nm,scr,des,loc] <- mapM get ["id","name","screen_name","description","location"] + prot <- getMbB "protected" + mbU <- getMbS "url" + mbP <- getMbS "profile_image_url" + mbF <- getMbI "followers_count" + return nullUser + { userId = i + , userName = nm + , userScreenName = scr + , userDescription = des + , userLocation = loc + , userProfileImageURL = mbP + , userURL = mbU + , userProtected = prot + , userFollowers = mbF + } + +showStatus :: Status -> [(String, JSValue)] +showStatus s = + [ "created_at" -=> str $ statusCreated s + , "id" -=> str $ statusId s + , "text" -=> str $ statusText s + , "source" -=> str $ statusSource s + , "truncated" -=> bool $ statusTruncated s + , "user" -=> showJSON $ statusUser s + ] ++ catMaybes + [ mb "in_reply_to_status_id" str (statusInReplyTo s) + , mb "in_reply_to_user_id" str (statusInReplyToUser s) + , mb "favorited" bool (statusFavorite s) + ] + +readStatus :: JM Status +readStatus = do + st <- getMb "status" + augment <- + case st of + Just (JSObject (JSONObject ps)) -> do + ls <- getEnv + return (addToEnv (("user", JSObject (JSONObject ls)):ps)) + _ -> return id + augment $ do + [cr,i,te,src] <- mapM get ["created_at","id","text","source"] + u <- getJ "user" + tr <- getB "truncated" + inr <- getMbS "in_reply_to_status_id" + inu <- getMbS "in_reply_to_user_id" + fa <- getMbB "favorited" +-- u <- getMbJ "user" + return nullStatus + { statusCreated = cr + , statusId = i + , statusText = te + , statusSource = src + , statusTruncated = tr + , statusInReplyTo = inr + , statusInReplyToUser = inu + , statusFavorite = fa + , statusUser = u + } + +showUserInfo :: UserInfo -> [(String, JSValue)] +showUserInfo u = + [ "profile_background_tile" -=> bool $ userInfoBackgroundTile u + , "profile_link_color" -=> str $ userInfoLinkColor u + , "profile_background_color" -=> str $ userInfoBackground u + , "profile_text_color" -=> str $ userInfoTextColor u + , "profile_sidebar_fill_color" -=> str $ userInfoSidebarFill u + , "profile_sidebar_border_color" -=> str $ userInfoSidebarColor u + , "profile_background_image_url" -=> str $ userInfoBackgroundImageURL u + , "followers_count" -=> int $ userInfoFollowers u + , "description" -=> str $ userInfoDescription u + , "utc_offset" -=> int $ userInfoUTCOffset u + , "favourites_count" -=> int $ userInfoFavorites u + , "created_at" -=> str $ userInfoCreated u + , "time_zone" -=> str $ userInfoTimezone u + , "profile_image_url" -=> str $ userInfoImageURL u + , "statuses_count" -=> int $ userInfoStatusCount u + , "friends_count" -=> int $ userInfoFriends u + , "screen_name" -=> str $ userInfoScreenName u + , "protected" -=> bool $ userInfoProtected u + , "location" -=> str $ userInfoLocation u + , "name" -=> str $ userInfoName u + , "id" -=> str $ userInfoId u + ] ++ catMaybes + [ mb "url" str (userInfoURL u) + ] + +readUserInfo :: JM UserInfo +readUserInfo = do + [ lc,bg,tc + , sf,sbg,burl + , desc,cre,tz + , sn,loc + , nm,i] + <- mapM get [ "profile_link_color" + , "profile_background_color" + , "profile_text_color" + , "profile_sidebar_fill_color" + , "profile_sidebar_border_color" + , "profile_background_image_url" + , "description" + , "created_at" + , "time_zone" + , "screen_name" + , "location" + , "name" + , "id" + ] + prot <- getB "protected" + bgt <- getB "profile_background_tile" + fo <- getInt "followers_count" + utc <- getInt "utc_offset" + fav <- getInt "favourites_count" + sc <- getInt "statuses_count" + fri <- getInt "friends_count" + imgurl <- get "profile_image_url" + iurl <- getMbS "url" + return UserInfo + { userInfoBackgroundTile = bgt + , userInfoLinkColor = lc + , userInfoBackground = bg + , userInfoBackgroundImageURL = burl + , userInfoTextColor = tc + , userInfoSidebarFill = sf + , userInfoSidebarColor = sbg + , userInfoFollowers = fromInteger fo + , userInfoDescription = desc + , userInfoUTCOffset = fromInteger utc + , userInfoFavorites = fromInteger fav + , userInfoCreated = cre + , userInfoTimezone = tz + , userInfoImageURL = imgurl + , userInfoURL = iurl + , userInfoStatusCount = fromInteger sc + , userInfoFriends = fromInteger fri + , userInfoScreenName = sn + , userInfoProtected = prot + , userInfoLocation = loc + , userInfoName = nm + , userInfoId = i + } + +showDM :: DirectMessage -> [(String, JSValue)] +showDM s = + [ "sender_id" -=> str $ directSenderId s + , "recipient_id" -=> str $ directRecipientId s + , "recipient_screen_name" -=> str $ directRecipientName s + , "sender_screen_name" -=> str $ directSenderName s + , "text" -=> str $ directText s + , "id" -=> str $ directId s + , "created_at" -=> str $ directCreated s + ] ++ catMaybes + [ mb "recipient" js (directRecipient s) + , mb "sender" js (directSender s) + ] + +readDM :: JM DirectMessage +readDM = do + [sid,rid,rscr,sscr,txt,i,cre] <- mapM get ["sender_id","recipient_id","recipient_screen_name", "sender_screen_name", "text", "id", "created_at"] + rec <- getMbJ "recipient" + sen <- getMbJ "sender" + return nullDirectMessage + { directSenderId = sid + , directRecipientId = rid + , directRecipientName = rscr + , directSenderName = sscr + , directText = txt + , directId = i + , directCreated = cre + , directRecipient = rec + , directSender = sen + } + +showRateLimit :: RateLimit -> [(String, JSValue)] +showRateLimit r = + [ "reset_time_in_seconds" -=> inte $ rateLimitResetSecs r + , "reset_time" -=> str $ rateLimitResetTime r + , "remaining_hits" -=> inte $ rateLimitRemHits r + , "hourly_limit" -=> inte $ rateLimitHourlyLimit r + ] + +readRateLimit :: JM RateLimit +readRateLimit = do + rs <- getInt "reset_time_in_seconds" + rt <- get "reset_time" + rh <- getInt "remaining_hits" + rl <- getInt "hourly_limit" + return nullRateLimit + { rateLimitResetSecs = rs + , rateLimitResetTime = rt + , rateLimitRemHits = rh + , rateLimitHourlyLimit = rl + } + diff --git a/hs-twitter.cabal b/hs-twitter.cabal new file mode 100644 --- /dev/null +++ b/hs-twitter.cabal @@ -0,0 +1,40 @@ +name: hs-twitter +version: 0.2.0 +synopsis: Haskell binding to the Twitter API +description: + The hs-twitter API binding lets you access twitter.com's + resources and methods from Haskell. Implements the + full API, as specified at + . + For more info on use, please visit + +category: Web +license: BSD3 +license-file: LICENSE +author: Sigbjorn Finne +maintainer: Sigbjorn Finne +cabal-version: >= 1.2 +build-type: Simple +extra-source-files: README + +flag old-base + description: Old, monolithic base + default: False + +library + Exposed-modules: Web.Twitter, + Web.Twitter.Types, + Web.Twitter.Types.Import, + Web.Twitter.Monad, + Web.Twitter.Fetch, + Web.Twitter.MIME, + Web.Twitter.Post, + Web.Codec.URLEncoder, + Web.Codec.Percent + Ghc-Options: -Wall + build-depends: HTTP >= 4000.0.1, network, utf8-string, json, mime, old-locale, old-time, random + + if flag(old-base) + Build-Depends: base < 3 + else + Build-Depends: base >= 4