hs-twitter 0.2.1 → 0.2.2

raw patch · 5 files changed

+341/−29 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Web/Twitter.hs +170/−8
• Web/Twitter/Monad.hs +11/−1
• Web/Twitter/Types.hs +64/−3
• Web/Twitter/Types/Import.hs +95/−16
• hs-twitter.cabal +1/−1

@@ -65,12 +65,19 @@        , createBlock     -- :: UserId -> TM User
        , destroyBlock    -- :: UserId -> TM User
 
-       , testCall                -- :: TM String
+       , testCall        -- :: TM String
        
+       , search          -- :: String -> Maybe SearchContext -> TM [Status]
+       , getTrends       -- :: TM [Status]
+       , SearchContext(..)
+       , searchFor
+       
        , setUpdateInterval
        , setTwitterUser
        , tweet
        , stopUpdates
+       , addSearchFilter
+       , dropSearch
 
        ) where
 
@@ -98,6 +105,12 @@ 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: "
@@ -109,6 +122,8 @@        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)
@@ -119,12 +134,77 @@     case x of
       Nothing -> updateChecker everyMins mbSince
       Just au -> do
-	 n  <- nowDateString
-         ls <- runTM au (getFriendsTimeline mbSince Nothing)
+	 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
+                       -- update the sinceId so as to not repeat entries next time around..
+		    return (sid,s{searchSinceId=searchResultId (head ss)})
+         ls1 <- mapM doOneSearch ls
+	 let updateSC y@(s,_) =
+		   -- replace with new sinceId
+	       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
@@ -147,7 +227,7 @@    r <- readMVar twitter_user
    case r of
      Nothing -> do
-       putStrLn "Unable to tweet, no user set - run 'setTwitterUser'"
+       putStrLn "Unable to tweet, no user set - run 'setTwitterUser'" -- "
        return ()
      Just au -> do
        runTM au (update s Nothing)
@@ -462,10 +542,10 @@ updateProfile :: ProfileInfo -> TM ()
 updateProfile pin = withBase acc_base_url $ withAuth True $ postMethod $
   restCall acc 
-           (mbArg "name" (profileInfoName pin) $
+           (mbArg "name"        (profileInfoName pin) $
 	    mbArg "email"       (profileInfoEmail pin) $
-	    mbArg "url"       (profileInfoURL pin) $
-	    mbArg "location" (profileInfoLocation pin) $
+	    mbArg "url"         (profileInfoURL pin) $
+	    mbArg "location"    (profileInfoLocation pin) $
 	    mbArg "description" (profileInfoDescription pin) $
 	    []) >> return ()
  where
@@ -533,4 +613,86 @@ -- | @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"
+testCall = withBase top_base_url $ withAuth False $ 
+   restCall "help/test.json" [] >>= readResult "testCall"
+
+-- The "Search API"
+--
+
+-- | @testCall@ returns the string "ok" in the requested format 
+-- with a 200 OK HTTP status code.
+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 -- location name
+       }
+
+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) $
+        -- this doesn't appear to work as expected via the .json interface
+     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
+	    

@@ -27,13 +27,15 @@        , user_base_url
        , top_base_url
        , acc_base_url
---       , buildUrl
+       , search_base_url
        
        , Result(..)
        , decodeStrict
        
        , mbArg
        , arg
+       , strArg
+
        , restCall
        , postCall
        , readResult
@@ -61,6 +63,9 @@ acc_base_url :: URLString
 acc_base_url = "http://www.twitter.com/account/"
 
+search_base_url :: URLString
+search_base_url = "http://search.twitter.com/"
+
 {-
 buildUrl :: (URLString -> IO a) -> URLString -> TM a
 buildUrl f u = do
@@ -74,6 +79,11 @@ 
 arg :: String -> String -> [(String,String)] -> [(String,String)]
 arg f x xs = (f,x):xs
+
+strArg :: String -> String -> [(String,String)] -> [(String,String)]
+strArg _ "" xs = xs
+strArg f  x xs = (f,x):xs
+
 
 restCall :: String -> [(String,String)] -> TM String
 restCall u args = do

@@ -1,3 +1,19 @@+--------------------------------------------------------------------
+-- |
+-- Module      : Web.Twitter.Types
+-- Description : Main types introduced by the Twitter API
+-- Copyright   : (c) Sigbjorn Finne, 2008
+-- License     : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
+-- Stability : provisional
+-- Portability: portable
+--
+-- This module defines the main types that the Haskell API binding
+-- for Twitter introduces. Most importantly, if that's the word,
+-- the representation of tweets\/status updates.
+-- 
+--------------------------------------------------------------------
 module Web.Twitter.Types where
 
 type ColorString = String
@@ -6,17 +22,20 @@ type UserId      = String
 type URLString   = String
 type UserName    = String
+type StatusId    = String
 
 data Format = FormatXML | FormatJSON | FormatRSS | FormatAtom
 
+-- | @Status@ is the record type used to represent a ''tweet'',
+-- a status update by a user.
 data Status
  = Status
      { statusCreated       :: DateString
-     , statusId            :: String
+     , statusId            :: StatusId
      , statusText          :: String
      , statusSource        :: String
      , statusTruncated     :: Bool
-     , statusInReplyTo     :: Maybe String
+     , statusInReplyTo     :: Maybe StatusId
      , statusInReplyToUser :: Maybe UserId
      , statusFavorite      :: Maybe Bool
      , statusUser          :: User
@@ -122,7 +141,7 @@      , directRecipientId   :: UserId
      , directRecipientName :: UserId
      , directText          :: String
-     , directId            :: UserId -- mis-named, but works.
+     , directId            :: StatusId -- mis-named, but works.
      , directCreated       :: DateString
      }
 
@@ -139,6 +158,8 @@      , directCreated       = ""
      }
 
+-- | @RateLimit@ bundles up the data that the 'getRateLimit'
+-- Twitter API call returns regarding API call limits.
 data RateLimit
  = RateLimit
      { rateLimitResetSecs :: Integer
@@ -153,4 +174,44 @@      , rateLimitResetTime = ""
      , rateLimitRemHits   = 0
      , rateLimitHourlyLimit = 0
+     }
+
+-- | @Trends@ bundles up the data that the 'trends'
+-- Twitter Search API call returns regarding what's
+-- being majorly tweeted about.
+data Trends
+ = Trends
+     { trendsAsOf :: DateString
+     , trendsInfo :: [(String{-name-}, URLString)]
+     }
+
+nullTrends :: Trends
+nullTrends = Trends
+     { trendsAsOf = ""
+     , trendsInfo = []
+     }
+
+-- | @SearchResult@ bundles up the data that the Search API returns.
+data SearchResult
+ = SearchResult
+     { searchResultText       :: String
+     , searchResultId         :: StatusId
+     , searchResultFromUser   :: UserName
+     , searchResultFromUserId :: UserId
+     , searchResultAt         :: DateString
+     , searchResultLanguage   :: Maybe String
+     , searchResultToUser     :: Maybe UserName
+     , searchResultToUserId   :: Maybe UserId
+     }
+
+nullSearchResult :: SearchResult
+nullSearchResult = SearchResult
+     { searchResultText       = ""
+     , searchResultId         = ""
+     , searchResultFromUser   = ""
+     , searchResultFromUserId = ""
+     , searchResultAt         = ""
+     , searchResultLanguage   = Nothing
+     , searchResultToUser     = Nothing
+     , searchResultToUserId   = Nothing
      }

@@ -9,7 +9,7 @@ import Data.Maybe
 import Control.Monad
 
-import Debug.Trace
+--import Debug.Trace
 
 data JM a = JM (String -> [(String,JSValue)] -> Result a)
 
@@ -43,7 +43,7 @@   m   <- getMb k
   case m of
     Just (JSString s)  -> return (fromJSString s)
-    Just js -> return (showJSValue js "")
+    Just jso -> return (showJSValue jso "")
     Nothing -> do
        loc <- getLoc
        fail (loc ++ ": missing value for key " ++ show k)
@@ -87,6 +87,14 @@        loc <- getLoc
        fail (loc ++ ": unable to locate expected JSON field " ++ show k)
 
+getArr :: String -> JM [JSValue]
+getArr k = do
+  v <- getMb k
+  case v of
+    Just (JSArray as) -> return as
+    _      -> do
+       loc <- getLoc
+       fail (loc ++ ": unable to locate expected JSON (array) field " ++ show k)
 
 getMbB :: String -> JM (Maybe Bool)
 getMbB k = do
@@ -122,36 +130,47 @@ 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])
+readJS :: String -> String -> a -> (JM a) -> JSValue -> Result a
+readJS _ _ n _ (JSArray []) = return n
+readJS m q n f (JSArray [x]) = readJS m q n f x
+readJS loc nm n f (JSObject (JSONObject [(x,ls@JSArray{})])) 
+  | nm == x = readJS loc nm n f ls
+readJS m _ _ f (JSObject (JSONObject pairs)) = runJM m pairs f
+readJS m _ _ _ v = fail (m ++ ": unexpected JSON value " ++ show v)
 
 instance JSON User where
     showJSON u = showJS showUser u
-    readJSON m = readJS "Web.Twitter.Types.User" nullUser readUser m
+    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
+    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
+    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
+    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
+    readJSON m = readJS "Web.Twitter.Types.RateLimit" "" nullRateLimit readRateLimit m
     
+instance JSON Trends where
+    showJSON u = showJS showTrends u
+    readJSON m = readJS "Web.Twitter.Types.Trends" "" nullTrends readTrends m
+
+instance JSON SearchResult where
+    showJSON u = showJS showSearchResult u
+    readJSON m = readJS "Web.Twitter.Types.SearchResult" "results" nullSearchResult readSearchResult m
+
+    readJSONs (JSObject (JSONObject (("results", JSArray xs):_))) = do
+       mapM (\ x -> readJS "Web.Twitter.Types.SearchResult" "results" nullSearchResult readSearchResult x) xs
+
+    readJSONs _  = Error ("Unable to read search results")
+
 showUser :: User -> [(String, JSValue)]
 showUser u = 
   [ "id"           -=> str  $ userId u
@@ -175,6 +194,12 @@ bool :: Bool -> JSValue
 bool f = showJSON (JSBool f)
 
+arr :: [JSValue] -> JSValue
+arr s  = showJSON (JSArray s)
+
+obj :: [(String,JSValue)] -> JSValue
+obj s  = showJSON (JSObject (JSONObject s))
+
 js :: JSON a => a -> JSValue
 js = showJSON
 
@@ -388,3 +413,57 @@       , rateLimitHourlyLimit = rl
       }
 
+
+showTrends :: Trends -> [(String, JSValue)]
+showTrends t = 
+  [ "as_of"   -=> str  $ trendsAsOf t
+  , "trends"  -=> arr  $ (map (\ (a,b) -> obj [("name", showJSON a), ("url", showJSON b)])
+                              (trendsInfo t))
+  ]
+
+readTrends :: JM Trends
+readTrends = do
+  rs <- get "as_of"
+  as <- getArr "trends"
+  ls <- mapM readEntry as
+  return nullTrends
+      { trendsAsOf = rs
+      , trendsInfo = ls
+      }
+  where 
+   readEntry (JSObject (JSONObject os)) = addToEnv os $ do
+      a <- get "name"
+      b <- get "url"
+      return (a,b)
+   readEntry _ = return ("","")
+      
+
+showSearchResult :: SearchResult -> [(String,JSValue)]
+showSearchResult s = 
+  [ "text"  -=> str  $ searchResultText s
+  , "id"    -=> str  $ searchResultId s
+  , "from_user" -=> str $ searchResultFromUser s
+  , "from_user_id" -=> str $ searchResultFromUserId s
+  , "created_at"    -=> str $ searchResultAt s
+  ] ++ catMaybes
+   [  mb "language_code" str (searchResultLanguage s)
+   ,  mb "to_user_id"    str (searchResultToUserId s)
+   ,  mb "to_user"       str (searchResultToUser s)
+   ]
+
+readSearchResult :: JM SearchResult
+readSearchResult = do
+  [tx,i,fu,fui,ca] <- mapM get  ["text", "id", "from_user", "from_user_id", "created_at"]
+  l   <- getMbS "language_code"
+  tu  <- getMbS "to_user"
+  tui <- getMbS "to_user_id"
+  return nullSearchResult
+     { searchResultText = tx
+     , searchResultId   = i
+     , searchResultFromUser = fu
+     , searchResultFromUserId = fui
+     , searchResultAt = ca
+     , searchResultLanguage = l
+     , searchResultToUser   = tu
+     , searchResultToUserId = tui
+     }

@@ -1,5 +1,5 @@ name: hs-twitter
-version: 0.2.1
+version: 0.2.2
 synopsis: Haskell binding to the Twitter API
 description:
    The hs-twitter API binding lets you access twitter.com's