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
, search
, getTrends
, SearchContext(..)
, searchFor
, setUpdateInterval
, setTwitterUser
, tweet
, stopUpdates
, addSearchFilter
, dropSearch
) 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))
twitter_get_action :: MVar (Maybe String -> TM [Status])
twitter_get_action = unsafePerformIO (newMVar (\ _ -> return []))
twitter_searches :: MVar (SearchId, [(SearchId,SearchContext)],Maybe ThreadId)
twitter_searches = unsafePerformIO (newMVar (0,[],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 ())
modifyMVar_ twitter_get_action
(\ _ -> return (\ x -> getFriendsTimeline x Nothing))
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
upd <- readMVar twitter_get_action
ls <- runTM au (upd mbSince)
when (not $ null ls) (putStrLn "")
mapM_ (\ s -> putStrLn (userScreenName (statusUser s) ++ ": " ++ statusText s)) ls
updateChecker everyMins (Just n)
type SearchId = Int
addSearchFilter :: SearchContext -> IO SearchId
addSearchFilter sc = do
st <- readMVar twitter_searches
t <-
case st of
(_,_,Just t) -> return t
(_,_,Nothing) -> do
putStr "Perform tracking/searches every X mins: "
l <- getLine
let readIt x = case reads x of { ((v,_):_) -> v ; _ -> 1}
forkIO (searchBot (readIt l) Nothing)
(a,b,_) <- takeMVar twitter_searches
putMVar twitter_searches (a+1,(a,sc):b,Just t)
return (a+1)
where
searchBot p mbSinceId = do
threadDelay (p * 1000000 * 60)
x <- readMVar twitter_searches
u <- readMVar twitter_user
case (u,x) of
(Nothing,_) -> searchBot p mbSinceId
(_, (_,[],_)) -> searchBot p mbSinceId
(Just au, (_,ls,_)) -> do
n <- nowDateString
let doOneSearch st@(sid,s) = do
ss <- runTM au (search s)
case ss of
[] -> return st
_ -> do
let ifn "" c = c
ifn c _ = c
let label = searchQuery s `ifn`
searchPhrase s `ifn`
searchHashTag s `ifn`
("<"++shows sid ">")
putStrLn ("Search results for: " ++ label)
mapM_ ( \ r -> putStrLn (searchResultFromUser r ++ ": " ++
searchResultText r ++ " @ " ++
searchResultAt r))
ss
return (sid,s{searchSinceId=searchResultId (head ss)})
ls1 <- mapM doOneSearch ls
let updateSC y@(s,_) =
maybe y (\ v -> (s,v)) (lookup s ls1)
modifyMVar_ twitter_searches (\ (a,xs,b) -> return (a,map updateSC xs,b))
searchBot p (Just n)
dropSearch :: SearchId -> IO ()
dropSearch s = do
(a,ls,b) <- takeMVar twitter_searches
ls1 <-
case break(\ x -> fst x == s) ls of
(_,[]) -> do
putStrLn ("Unknown search ID; ignoring")
return ls
(as,_:bs) ->
return (as++bs)
putMVar twitter_searches (a,ls1,b)
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"
getTrends :: TM Trends
getTrends = withBase search_base_url $ withAuth False $ do
restCall "trends.json" [] >>= readResult "getTrends"
data SearchContext
= SearchContext
{ searchLang :: String
, searchRPP :: Int
, searchPage :: Int
, searchSinceId :: StatusId
, searchGeocode :: String
, searchShowUser :: Bool
, searchQuery :: String
, searchHashTag :: String
, searchFromUser :: UserName
, searchToUser :: UserName
, searchReferring :: UserName
, searchAllWords :: [String]
, searchAnyWords :: [String]
, searchNoneWords :: [String]
, searchPhrase :: String
, searchNear :: String
}
searchFor :: SearchContext
searchFor = SearchContext
{ searchLang = "all"
, searchRPP = 15
, searchPage = 1
, searchSinceId = ""
, searchGeocode = ""
, searchShowUser = True
, searchQuery = ""
, searchHashTag = ""
, searchFromUser = ""
, searchToUser = ""
, searchReferring = ""
, searchAllWords = []
, searchAnyWords = []
, searchNoneWords = []
, searchPhrase = ""
, searchNear = ""
}
search :: SearchContext
-> TM [SearchResult]
search scon = withBase search_base_url $
restCall acc (searchArgs scon []) >>= readResult "search"
where
acc = "search.json"
searchArgs sc ls =
strArg "lang" (searchLang sc) $
strArg "rpp" (show $ searchRPP sc) $
strArg "page" (show $ searchPage sc) $
strArg "since_id" (searchSinceId sc) $
strArg "geocode" (searchGeocode sc) $
strArg "show_user" (searchSinceId sc) $
strArg "tag" (searchHashTag sc) $
strArg "q" (searchQuery sc) $
strArg "from" (searchFromUser sc) $
strArg "to" (searchToUser sc) $
strArg "ref" (searchReferring sc) $
strArg "ands" (unwords $ searchAllWords sc) $
strArg "ors" (unwords $ searchAnyWords sc) $
strArg "nots" (unwords $ searchNoneWords sc) $
strArg "phrase" (searchPhrase sc) $
strArg "near" (searchNear sc) $
strArg "within" ((\ x -> if x == "" then "" else "15") $ searchNear sc) $
strArg "units" ((\ x -> if x == "" then "" else "mi") $ searchNear sc) $
ls