module Web.Twitter
( getPublicTimeline
, getFriendsTimeline
, getUserTimeline
, showStatus
, update
, getReplies
, destroyStatus
, getFriends
, getFollowers
, getUserInfo
, getDirectMessages
, getDirectMessagesSent
, sendDirectMessage
, destroyDirectMessage
, createFriend
, destroyFriend
, isFriendOf
, verifyCredentials
, endSession
, updateDeliveryDevice
, ProfileColors(..)
, nullProfileColors
, updateProfileColors
, updateProfileImage
, updateProfileBackgroundImage
, RateLimit(..)
, nullRateLimit
, getRateLimit
, ProfileInfo(..)
, nullProfileInfo
, updateProfile
, getFavorites
, createFavorite
, destroyFavorite
, followUser
, leaveUser
, createBlock
, destroyBlock
, testCall
, 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
import Control.Concurrent
import Control.Monad
import System.IO.Unsafe
import System.Time
import System.Locale
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
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
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 :: TM [Status]
getPublicTimeline = withAuth False $ restCall pub [] >>= readResult "getPublicTimeline"
where pub = "public_timeline.json"
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 :: 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 :: String -> TM Status
showStatus i = withAuth True $ restCall usr [] >>= readResult "showStatus"
where
usr = "show/" ++ i ++ ".json"
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 :: 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 :: String -> TM ()
destroyStatus i = withAuth True $ postMethod $ restCall des [] >> return ()
where
des = "destroy/" ++ i ++ ".json"
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 :: Maybe String -> TM [Status]
getFollowers mbId = withAuth True $ restCall folly [] >>= readResult "getFollowers"
where
folly = maybe "followers.json" (\ i -> "followers/" ++ i ++ ".json") mbId
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
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 :: 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 -> String -> TM DirectMessage
sendDirectMessage uId txt = withBase top_base_url $ withAuth True $ postMethod $
restCall dir
(arg "user" uId $ arg "text" txt []) >>= readResult "sendDirectMessage"
where
dir = "direct_messages/new.json"
destroyDirectMessage :: UserId -> TM ()
destroyDirectMessage i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >> return ()
where
des = "direct_messages/destroy/" ++ i ++ ".json"
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 :: UserId -> TM User
destroyFriend i = withBase top_base_url $ withAuth True $ postMethod $
restCall des [] >>= readResult "destroyFriend"
where
des = "friendships/destroy/" ++ i ++ ".json"
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 :: TM User
verifyCredentials = withBase acc_base_url $ withAuth True $
restCall acc [] >>= readResult "verifyCredentials"
where
acc = "verify_credentials.json"
endSession :: TM ()
endSession = withBase acc_base_url $ withAuth True $ postMethod $
restCall acc [] >> return ()
where
acc = "end_session"
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
nullProfileColors
= ProfileColors
{ profileTextColor = Nothing
, profileBackColor = Nothing
, profileLinkColor = Nothing
, profileSidebarFill = Nothing
, profileSidebarBorder = Nothing
}
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 :: 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
(_,_,_) <- postCall u hs bod []
return ()
where
acc = "update_profile_image.json"
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
(_,_,_) <- postCall u hs bod []
return ()
where
acc = "update_profile_background_image.json"
getRateLimit :: TM RateLimit
getRateLimit = withBase acc_base_url $ withAuth True $ do
restCall acc [] >>= readResult "getRateLimit"
where
acc = "rate_limit_status.json"
appendQueryArgs :: String -> String -> String
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 -> TM ()
updateProfile pin = withBase acc_base_url $ withAuth True $ postMethod $
restCall acc
(mbArg "name" (profileInfoName pin) $
mbArg "email" (profileInfoEmail pin) $
mbArg "url" (profileInfoURL pin) $
mbArg "location" (profileInfoLocation pin) $
mbArg "description" (profileInfoDescription pin) $
[]) >> return ()
where
acc = "update_profile.json"
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 :: UserId -> TM User
createFavorite i = withBase top_base_url $ withAuth True $ postMethod $
restCall dir [] >>= readResult "createFavorite"
where
dir = "favorites/create/"++i++".json"
destroyFavorite :: UserId -> TM User
destroyFavorite i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >>= readResult "destroyFavorite"
where
des = "favorites/destroy/" ++ i ++ ".json"
followUser :: UserId -> TM User
followUser i = withBase top_base_url $ withAuth True $ postMethod $
restCall dir [] >>= readResult "followUser"
where
dir = "notifications/follow/"++i++".json"
leaveUser :: UserId -> TM User
leaveUser i = withBase top_base_url $ withAuth True $ postMethod $
restCall dir [] >>= readResult "leaveUser"
where
dir = "notifications/leave/"++i++".json"
createBlock :: UserId -> TM User
createBlock i = withBase top_base_url $ withAuth True $ postMethod $
restCall dir [] >>= readResult "createBlock"
where
dir = "blocks/create/"++i++".json"
destroyBlock :: UserId -> TM User
destroyBlock i = withBase top_base_url $ withAuth True $ postMethod $ restCall des [] >>= readResult "destroyBlock"
where
des = "blocks/destroy/" ++ i ++ ".json"
testCall :: TM String
testCall = withBase top_base_url $ withAuth False $ restCall "help/test.json" [] >>= readResult "testCall"